Kopieren waarde indien aan voorwaarde is voldaan

Status
Niet open voor verdere reacties.

Eejjf

Gebruiker
Lid geworden
8 mei 2018
Berichten
27
Beste iedereen,

Wederom een vraag van mij.. 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:
Private Sub CommandButton1_Click()
Dim LastRow As Long
   Dim i As Long, j As Long

   'zoekt laatste row
   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

   'terugkoppeling naar bestelform
   With Worksheets("Bestellformular")
      j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
   End With
    
  'kopieren naar bestelform 
   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?

Wederom bedankt,

Eva

Bekijk bijlage Bestelformular.xlsm
 
Ik heb er niet direct naar gekeken maar hou er wel rekening mee dat LastRow alleen door dit stukje wordt bepaalt omdat het de laatste is die deze waarde ophaalt:
Code:
   With Worksheets("Mineralien")
     LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   End With

Waarom je die anderen er voor hebt staan is mij een raadsel.
 
Iets minder flipperkast.

Code:
Private Sub CommandButton1_Click()
  For Each sh In Sheets(Array("Übriger", "Darmbakterien", "Intestinum aufbauschutz", "Verdauungsenzyme", "Leber Entgiftung Dysbiose Infla", "Stress regulierung vitamin b km", "Mineralien"))
    ar = sh.Cells(1).CurrentRegion
    t = 0
    ReDim ar1(UBound(ar), UBound(ar, 2))
    For j = 2 To UBound(ar)
      If ar(j, 11) <> "" Then
        For jj = 1 To UBound(ar, 2)
          ar1(t, jj - 1) = ar(j, jj)
        Next jj
        t = t + 1
      End If
    Next j
    Sheets("Bestellformular").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(t, UBound(ar, 2)) = ar1
  Next sh
End Sub
 
Nog weer iets minder.
Code:
Private Sub CommandButton1_Click()
 ReDim ar1(10, 0)
  For Each sh In Sheets(Array("Übriger", "Darmbakterien", "Intestinum aufbauschutz", "Verdauungsenzyme", "Leber Entgiftung Dysbiose Infla", "Stress regulierung vitamin b km", "Mineralien"))
    ar = sh.Cells(1).CurrentRegion
   
    For j = 2 To UBound(ar)
      If ar(j, 11) <> "" Then
        For jj = 1 To UBound(ar, 2)
          ar1(jj - 1, t) = ar(j, jj)
        Next jj
        t = t + 1
        ReDim Preserve ar1(10, t)
      End If
    Next j
    Next sh
 Sheets("Bestellformular").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(t, UBound(ar, 2)) = Application.Transpose(ar1)
End Sub
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan