Dezelfde macro voor verschillende worksheets

[Chicky87]

Hallo iedereen,

Ik zit met het volgende probleempje:

Ik heb een excel-bestand (helaas te groot om bij te voegen) waarin een aantal data-sheets bestaan met productinformatie, en een aantal bladen per leverancier.

De macro die ik heb geprogrammeerd selecteerd steeds de regels in de product-sheets die bij een bepaalde leverancier horen, en zet deze weg in de juiste leverancier-sheet.

De bladen van producten hebben de naam van het product (dus niet opvolgend) en de leveranciersbladen heten 1, 2, 3 etc. tot 140.. Hierdoor hoef ik de macro per leverancier maar één keer te programmeren, omdat ik deze naam automatisch kan laten doortellen (for s = 1 to 140).

Nu de vraag: is dit ook mogelijk voor de producten? Ik heb nu namelijk 8 keer dezelfde macro, voor ieder product. De macro is alsvolgd:

With Sheets("XT4")
    Sheets(Name).Cells(r - 1, 1) = "XT4"
    With Sheets(Name).Cells(r - 1, 1).Font
        .Size = 12
        .Bold = True
    End With

    i = 5
    Do Until .Cells(i, 1) = ""
    If Trim(.Cells(i, 10)) = Supplier Then
        For k = 1 To 18
            Sheets(Name).Cells(r, k) = .Cells(i, k)            'Copy details if right supplier
        Next k
        r = r + 1
    End If
    i = i + 1
    Loop
    r = r + 2
End With

'Name' is trouwens het nummer van de leverancierssheet.
Hopelijk weet iemand een simpele oplossing.

Groet,

Hilde

 

[snb]

Het lijkt alsof je de ingebouwde autofilter-methode in VBA probeert te verbeteren

With Sheets("XT4")
    Sheets(Name).Cells(r - 1, 1) = "XT4"
    With Sheets(Name).Cells(r - 1, 1).Font
        .Size = 12
        .Bold = True
    End With
[COLOR="Blue"]    .cells(5,1).currentregion.autofilter 10,supplier
    .cells(5,1).currentregion.specialcells(xlcelltypevisible).copy Sheets(name).cells(r,1)[/COLOR]

Deze 2 blauwe regels code vervangen

    i = 5
    Do Until .Cells(i, 1) = ""
    If Trim(.Cells(i, 10)) = Supplier Then
        For k = 1 To 18
            Sheets(Name).Cells(r, k) = .Cells(i, k)            'Copy details if right supplier
        Next k
        r = r + 1
    End If
    i = i + 1
    Loop

Met de produkten kan het analoog

sq=split("produkt 1|produkt aa|produkt rgt|produkt 5hs|produkt jk22","|")
With Sheets("XT4").cells(5,1).currentregion
  for j=0 to ubound(sq)
    .autofilter 1,sq(j)
    .specialcells(xlcelltypevisible).copy Sheets(sq(j)).cells(rows.count,1).end(xlUp).offset(1)
  next
  .autofilter
End with

de namen van de produkten worden in een een-dimensionele matrix (array) gezet.
met een lus wordt in het gegevensgebied, waarin cel A5 zich bevindt, iedere waarde uit de matrix sq gefilterd als die waarde in kolom A voorkomt.
de gefilterde rijen worden gekopieerd naar de eerste lege regel van het werkblad met de naam van het produkt.
Autofilter wordt uitgeschakeld.