Bestelformulier, gegevens kopiëren van sheets (VBA/Excel)

[Verwijderd]

Hallo iedereen,

Recent ben ik begonnen met het onder de knie krijgen van excel i.c.m. VBA (weekje of twee). Ik probeer een bestelformulier op te stellen, met op de eerste sheet het "bestellformular". En op de andere sheets de categorieën waarin producten te bestellen zijn. Per tab/categorie kan men achter het product aangeven hoe vaak zij deze wensen te ontvangen. Wanneer men dan terug naar het bestelformulier gaat en dan op de knop "updaten formulier" drukt, had ik graag dat alle producten waar een aantal bij is aangegeven gekopieerd wordt naar de sheet "bestellformular".

Momenteel is dit mijn VBA code
Mijn excuses als het wat rommelig oogt/is.

code: filename

Private Sub CommandButton1_Click()
Dim LastRow As Long
   Dim i As Long, j As Long

   'Find the last used row in a Column: column A in this example
   With Worksheets("Übriger")
     LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   End With
   
   With Worksheets("Darmbakterien")
     LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   End With
   
   With Worksheets("Intestinum aufbauschutz")
     LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   End With
   
   With Worksheets("Verdauungsenzyme")
     LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   End With
   
   With Worksheets("Leber Entgiftung Dysbiose Infla")
     LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   End With
   
   With Worksheets("Stress regulierung vitamin b km")
     LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   End With
   
   With Worksheets("Mineralien")
     LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   End With

   'first row number where you need to paste values in Sheet1'
   With Worksheets("Bestellformular")
      j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
   End With
    
    
   For i = 2 To LastRow
       With Worksheets("Übriger")
           If .Cells(i, 11).Value >= 1 Then
               .Rows(i).Copy Destination:=Worksheets("Bestellformular").Range("A" & j)
               j = j + 1
           End If
       End With
       
        With Worksheets("Darmbakterien")
           If .Cells(i, 11).Value >= 1 Then
               .Rows(i).Copy Destination:=Worksheets("Bestellformular").Range("A" & j)
               j = j + 1
           End If
       End With
       
       With Worksheets("Intestinum aufbauschutz")
           If .Cells(i, 11).Value >= 1 Then
               .Rows(i).Copy Destination:=Worksheets("Bestellformular").Range("A" & j)
               j = j + 1
           End If
       End With

     With Worksheets("Verdauungsenzyme")
           If .Cells(i, 11).Value >= 1 Then
               .Rows(i).Copy Destination:=Worksheets("Bestellformular").Range("A" & j)
               j = j + 1
           End If
       End With

     With Worksheets("Leber Entgiftung Dysbiose Infla")
           If .Cells(i, 11).Value >= 1 Then
               .Rows(i).Copy Destination:=Worksheets("Bestellformular").Range("A" & j)
               j = j + 1
           End If
       End With

     With Worksheets("Stress regulierung vitamin b km")
           If .Cells(i, 11).Value >= 1 Then
               .Rows(i).Copy Destination:=Worksheets("Bestellformular").Range("A" & j)
               j = j + 1
           End If
       End With

     With Worksheets("Mineralien")
           If .Cells(i, 11).Value >= 1 Then
               .Rows(i).Copy Destination:=Worksheets("Bestellformular").Range("A" & j)
               j = j + 1
           End If
       End With
       
   Next i

End Sub

Het probleem: hij kiest artikelen en kopieert die naar de eerste sheet, weliswaar alleen artikelen met een aantal erachter. Maar hij pakt van de ene sheet 2 artikelen, terwijl er bij 4 een aantal staan en bij de andere sheet geen artikelen terwijl er achter 3 een aantal staat. Hij pakt wel telkens dezelfde artikelen.

Is er iemand die ziet wat ik fout heb gedaan?

Bvd

Eva

[breew]

@Verwijderd Er gaat sowieso iets mis met de variabele LastRow...
die bepaal je nu 7x, maar in de loop wordt natuurlijk alleen de laatste gebruikt! De oude LastRow wordt steeds overschreven!