For each maar dan anders

[JHABEK]

Ik ben bezig om een macro te schrijven waarin een uitgebreide lijst wordt gegenereerd aan de hand van een basis-lijst. Hierbij loop ik tegen het volgende probleem aan:

Het gaat hier om kledingstukken. In de eenvoudige lijst staat 1 kledingstuk per regel. In de uitgebreide lijst moet er een veelvoud aan regels worden aangemaakt aan de hand van het aantal maten van dit kledingstuk. Dus 5 maten betekend 5 regels met hetzelfde kledingstuk. Dit krijg ik nu voor elkaar in VBA

Nu wil ik, in de uitgebreide lijst, per regel de maat toevoegen. Stel dat we hetzelfde voorbeeld aanhouden, dan zijn er dus 5 maten. De macro kopieert deze 5 maten uit de maattabel en plakt deze in de uitgebreide tabel. Omdat ik een for each commando gebruik, gaat de macro nu naar de volgende cel in de betreffende kolom. Dit klopt echter niet, de macro zou naar de huidige cel + 5 (aantal maten) moeten gaan. Hoe krijg ik dat voor elkaar?

De code zoals ik het nu gebruik:

Sub Maatvoering()

Dim cl As Range

ActiveWorkbook.Sheets("Tussenbestand").Activate
Application.ScreenUpdating = False

For Each cl In Range("H2:H65536")
If cl.Value <> "" Then
    If cl.Value = "Mens" Then
ActiveWorkbook.Sheets("Maattabellen").Activate
Worksheets("Maattabellen").Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Copy
ActiveWorkbook.Sheets("Tussenbestand").Activate
cl.Offset(0, 2).Select
ActiveSheet.Paste

End If
End If
Next cl


End Sub

 

[Warme bakkertje]

Post eens een voorbeeldbestandje met een kledingstuk of 4 zodat wij iets hebben om mee te werken en waarin je aangeeft wat je wil bereiken.

 

[JHABEK]

Ik heb een voorbeeld gemaakt en toegevoegd in de bijlage.
Dit is even een handmatig voorbeeldje van de basislijst en de uitgebreide lijst (gebaseerd op maattabellen)

Mocht het nog niet duidelijk zijn dan licht ik het graag nog wat extra toe

 

[Mark xl]

Probeer dit eens, als het goed is werkt het ook als je de tabellen uitbreidt.

Sub UitgebreideLijst()
Dim wsBasis As Worksheet
Dim wsMaat As Worksheet
Dim a As Long
Dim b As Long
Dim c As Integer
Dim d As Long

Dim intMaatCol As Integer
Dim strCategorie As String

Set wsBasis = Sheets("Basislijst")
Set wsMaat = Sheets("Maattabel")
Sheets("Uitgebreide lijst").Select

' teller a houdt bij bij welk Kledingstuk we zijn in de basislijst
Do While wsBasis.Cells(1 + a, 1) <> ""
    'teller c loopt totdat er geen "categorie" van de basislijst overblijft _
    in het voorbeeld staan alleen mannen, deze kan uitgebreid worden
    Do While wsBasis.Cells(1 + a, 2 + c) <> ""
        strCategorie = wsBasis.Cells(1 + a, 2 + c)
        intMaatCol = Maatkolom(strCategorie)
        If intMaatCol <> 256 Then
        'teller d loopt totdat alle maten in de Maattabel vam de categorie string _
        zijn ingevuld
            Do While wsMaat.Cells(2 + d, intMaatCol) <> Empty
                'Teller b houdt bij welke regel van de uitgebreide lijst de volgende is
                Cells(1 + b, 1) = wsBasis.Cells(1 + a, 1)
                Cells(1 + b, 2) = strCategorie
                Cells(1 + b, 3) = wsMaat.Cells(2 + d, intMaatCol)
                d = d + 1
                b = b + 1
            Loop
            'reset rijteller van maattabel
            d = 0
        Else
            'maat niet gevonden
            Cells(1 + b, 1) = wsBasis.Cells(1 + a, 1)
            Cells(1 + b, 2) = strCategorie
            Cells(1 + b, 3) = "NIET GEVONDEN"
            b = b + 1
        End If
        c = c + 1
    Loop
    a = a + 1
    ' als alle categorieen zijn doorgelopen, reset C
    c = 0
Loop

Set wsBasis = Nothing
Set wsMaat = Nothing

End Sub
Function Maatkolom(ByVal strCategorie As String) As Integer
For i = 1 To 255
    If Sheets("Maattabel").Cells(1, i) = strCategorie Then Exit For
Next i
Maatkolom = i
End Function

Het lijkt ingewikkeld maar loop er maar eens doorheen met F8 (Stap voor stap)
2 matrices dynamisch combineren is niet altijd even simpel Het is altijd wel even opletten waar je je tellers door laat lopen

For...each is handig als je door bijvoorbeeld collections loopt, Maar voor dynamische loops kun je volgens mij beter For...To of Do...Loop gebruiken.

 

[Warme bakkertje]

@ Mark xl:
Als je in de basislijst een kolom bijmaakt gaat je macro in de fout

Sub tst()
r = Sheets("Basislijst").UsedRange.Rows.Count
c = Sheets("Basislijst").UsedRange.Columns.Count
r2 = Sheets("Maattabel").UsedRange.Rows.Count
sq = Sheets("Maattabel").Range("A2:A" & r2)
Sheets("Uitgebreide lijst").UsedRange.ClearContents
For Each cl In Sheets("Basislijst").Range("A1:A" & r)
    cl.Resize(, c).Copy Sheets("Uitgebreide lijst").Range(Chr(65 + c) & "65536").End(xlUp).Offset(1, -c)
    Sheets("Uitgebreide lijst").Range(Chr(65 + c) & "65536").End(xlUp).Offset(1).Resize(UBound(sq)) = sq
Next
With Sheets("Uitgebreide lijst").Range("A2:" & Chr(64 + c) & _
                Sheets("Uitgebreide lijst").Cells(Rows.Count, c + 1).End(xlUp).Row)
        .SpecialCells(4).Formula = "=R[-1]C"
        .Value = .Value
    End With
End Sub

 

[snb]

sub tst()
  sq=Sheets("Basislijst").UsedRange.resize(,20)
  sn=Sheets("Maattabel").UsedRange.resize(,20)
  for j=1 to Ubound(sq)
    for jj=1 to ubound(sn,2)-1
      sq(j,jj+1)=sn(j,jj)
    next
  next
  sheets("Uitgebreide lijst").cells(1,1).resize(ubound(sq),ubound(sq,2))=sq
End Sub

 

[JHABEK]

Heren (neem ik aan btw), bedankt voor jullie input.

@MarkXL:
Je code werkt naar behoren, maar de opmerking van Warme Bakkertje is terecht. Op het moment dat er in de basislijst een extra kolom staat, breekt de code en krijg je een onbetrouwbare uitgebreide lijst. Deze situatie komt in de praktijk regelmatig voor

@Warme Bakkertje
Jouw code hapert ook nog een beetje, als ik een extra kolom in de maattabel toevoeg, wordt deze niet meegenomen

@snb
Jouw code is echt veruit de snelste van de 3. Zeker als ik jouw code vergelijk met de mijne is er een verschil als dag en nacht vwb de snelheid. Maar ik moet wel bekennen dat ik behoorlijk overvraagt wordt met mijn VBA kennis. Ubound (welke ook gebruikt wordt door Warme Bakkertje) was bijvoorbeeld nog volledig onbekend bij mij. Ook deze code geeft nog de nodige foute output. Zo worden er onder andere geen extra regels per maat gekopieerd. Een kledingstuk met 4 maten heeft nog altijd maar 1 regel. Tevens worden de maten niet juist toegevoegd, waardoor de code dus nog niet doet wat hij moet doen.


Ik hink nu een beetje op de gedachte om de code van MarkXL te gebruiken, voorafgegaan door een stuk code waarin ik met een find, de juiste kolommen verplaats naar een nieuw blad om zo zijn code alsnog te kunnen gebruiken. Wat me daar op dit moment nog van weerhoudt is dat ik denk dat de route van SNB, ondanks dat er nu nog geen extra regels worden toegevoegd, uiteindelijk een substantieel snellere code op zal leveren. Helaas is mijn kennis van deze "manier" van programmeren nog te beperkt.

Wat ook van belang is om te melden, is dat er dadelijk een veelvoud aan kolommen toegevoegd moet gaan worden door de vba-code. Denk hierbij aan artikelnummers, inkoopprijzen welke doorgerekend worden naar retail en handelaarsprijzen, kleurcodes enzovoort. Het gaat hier in totaal om een 20-25 extra kolommen.

Wat is jullie advies aan mij? Verdiepen in de "SNB-Methode" of doorgaan volgens het voorstel van MarkXL en de data zo manipuleren dat zijn code bruikbaar wordt?

 

[Warme bakkertje]

Om je te bewijzen dat mijn macro wel degelijk werkt

 

[JHABEK]

Heej Rudi, inderdaad!

Ik heb je code nog wat aangepast en ben er nu verder mee aan het werken. De code is relatief snel, toch ben ik wel benieuwd naar reacties op mijn vraag of de methode welke SNB voorstelt uiteindelijk resulteert in een snellere code

 

[Warme bakkertje]

De code van snb is zonder twijfel de snelste omdat er uiteindelijk maar 1 schrijfbewerking plaatsvindt. Voor de doorsnee VBA-gebruiker (waaronder ikzelf) is het manipuleren van matrixen echter geen sinecure. Misschien dat de grootmeester der matrixen (snb) dit draadje terug oppikt en je alsnog een uitkomst biedt , anders heb je ondertussen toch al iets om mee te werken

 

[snb]

Sub tst()
    sq = Sheets("basislijst").UsedRange
    sn = Sheets("Maattabel").Range("A2:E7")
    
    For j = 1 To UBound(sq)
        For jj = 1 To 6 - IIf(Left(LCase(sq(j, 2)), 1) = "v", 2, 0)
          c01 = c01 & vbCr & sq(j, 1) & "|" & sq(j, 2) & "|" & sq(j, 3) & "|" & sn(jj, 1 + IIf(Left(LCase(sq(j, 2)), 1) = "v", 2, IIf(Left(LCase(sq(j, 2)), 1) = "k", 4, 0)))
        Next
    Next
    With Sheets("Uitgebreide lijst")
        .Cells(1, 1).Resize(UBound(Split(c01, vbCr))) = WorksheetFunction.Transpose(Split(Mid(c01, 2), vbCr))
        .Columns(1).TextToColumns , 1, -4142, , False, False, False, False, True, "|"
    End With
End Sub

 

[Mark xl]

Heren (neem ik aan btw), bedankt voor jullie input.
@MarkXL:
Je code werkt naar behoren, maar de opmerking van Warme Bakkertje is terecht. Op het moment dat er in de basislijst een extra kolom staat, breekt de code en krijg je een onbetrouwbare uitgebreide lijst. Deze situatie komt in de praktijk regelmatig voor
?

Volgens mijn benadering was dat ook zo bedoeld, maar na het bekijken van de oplosingen van WB en SNB en jouw reactie blijkt dat ik dat dus niet goed heb benaderd. zij gebruiken ook meer van de kracht van Excel en het aantal schrijfacties is minder waardoor het allemaal sneller loopt.

Succes verder..!