Actie bij laatste regel For Loop

Status
Niet open voor verdere reacties.
G

Geeseball

Gebruiker
Lid geworden
16 aug 2018
Berichten
5
**Alle getallen en begrippen zijn fictief en representeren niet de werkelijkheid**

Beste Forumleden,

Ik ben momenteel bezig met het schrijven van een code en op een onderdeel loop ik vast. Ik zal proberen in het kort, aan de hand van een voorbeeld, vertellen wat ik aan het doen ben en waar ik tegenaan loop.

Ik heb een bestand waarin staat op welke dag, welke producten besteld worden gegeven in hoeveelheid liters. in de voorbeeld code wordt alleen gerekend met de producten op dinsdag en die behoren tot de groep X. Deze twee eisen zijn ook verwerkt in de code. Ieder product heeft zijn eigen unieke locatie.

Op een pallet past bijvoorbeeld 1000 liter aan producten. Wanneer de code start wordt de locatie van het eerste product op de pallet genoteerd in een cel in een nieuw tabblad. Daarna begint de code de volumes van de producten bij elkaar op te tellen. Wanneer het volume van 1000 liter wordt overschreden wordt de locatie van het laatste product dat op de pallet past genoteerd in een cel in een nieuw tabblad. Vervolgens wordt dit proces herhaald. Op een gegeven moment zijn alle producten geweest en bereikt de laatste pallet niet het maximale volume van 1000 liter, hierdoor wordt de locatie van het laatste product op de pallet niet genoteerd.

Het lastige is dat mijn For Loop bestaat uit bijvoorbeeld 30.000 producten maar dat het laatste product dat voldoet aan de eisen (Alleen op dinsdag en behoren tot groep X) al op plek 15.000 staat.

Mijn vraag luidt dan ook: Hoe noteer ik de locatie van een product wanneer het product de laatste in de rij is die voldoet aan mijn eisen maar niet het laatste product is in de For Loop?

Als er vragen zijn dan hoor ik het graag. Daarnaast zijn tips ook altijd welkom ook al wordt er geen antwoord gegeven op de vraag. Ik leer graag bij!

Code: 
Sub PalletsMaken()

a = Worksheets("ZZZ").Cells(Rows.Count, 1).End(xlUp).Row


'###X-groep PALLETS###

'Alles verwijderen voor start
Worksheets("XXX").Rows("3:100").ClearContents


'Dinsdag
SOMdi = 0
UITGEVOERDdi = False
For Z = 4 To a
    If Worksheets("ZZZ").Cells(Z, 2).Value = "X" And Worksheets("ZZZ").Cells(Z, 25).Value <> "" Then
        SOMdi = SOMdi + Worksheets("ZZZ").Cells(Z, 25).Value
         If Not UITGEVOERDdi Then
            Worksheets("ZZZ").Cells(Z, 3).Copy
            Worksheets("XXX").Activate
            g = Worksheets("XXX").Cells(Rows.Count, 4).End(xlUp).Row
            Worksheets("XXX").Cells(g + 1, 4).Select
            ActiveSheet.Paste
            Worksheets("ZZZ").Activate
            UITGEVOERDdi = True
        End If
        If SOMdi >= 1000 Then
            Worksheets("ZZZ").Cells(Z, 3).Copy
            Worksheets("XXX").Activate
            f = Worksheets("XXX").Cells(Rows.Count, 4).End(xlUp).Row
            Worksheets("XXX").Cells(f + 1, 4).Select
            ActiveSheet.Paste
            Worksheets("ZZZ").Activate
            Z = Z - 1
            Worksheets("ZZZ").Cells(Z, 3).Copy
            Worksheets("XXX").Activate
            e = Worksheets("XXX").Cells(Rows.Count, 5).End(xlUp).Row
            Worksheets("XXX").Cells(e + 1, 5).Select
            ActiveSheet.Paste
            Worksheets("ZZZ").Activate
            SOMdi = SOMdi - SOMdi
        End If
    End If
Next Z

'Einde script
End Sub
 
Laatst bewerkt:
Svp niet quoten/citeren ! (staat in de link die ik plaatste).

Ik zie geen voorbeeldbestand.:(
 
Laatst bewerkt:
Nogmaals excuses, ik ben nieuw hier.

Ik heb een voorbeeld bestand gemaakt in het klein. In principe is het probleem hetzelfde. Bij de laatste pallet wordt de locatie van het laatste product op de laatste pallet niet genoteerd omdat de 200 liter niet wordt bereikt. Het maakt het extra lastig dat het laatste product op dinsdag halverwege binnen de For Loop valt.

De code die ik heb gemaakt is terug te vinden in het bestand maar ik zal hem hieronder ook nog even plaatsen.

Code: 
Sub PalletsMaken()

'Regel voor bereik
Dim StartRow As Integer
Dim EndRow As Integer
With Worksheets("Sheet1")
    StartRow = .Range("B:B").Find(what:="X", after:=Range("B1")).Row
    EndRow = .Range("B:B").Find(what:="X", after:=Range("B1"), searchdirection:=xlPrevious).Row
End With
MsgBox (StartRow)
MsgBox (EndRow)

'Verwijderen voor start
Worksheets("Sheet2").Rows("3:100").ClearContents

'Maandag

'dinsdag
SOMdi = 0
UITGEVOERDdi = False
For Z = StartRow To EndRow
    If Worksheets("Sheet1").Cells(Z, 5).Value <> "" Then
        SOMdi = SOMdi + Worksheets("Sheet1").Cells(Z, 5).Value
        If Not UITGEVOERDdi Then
            Worksheets("Sheet1").Cells(Z, 3).Copy
            Worksheets("Sheet2").Activate
            a = Worksheets("sheet2").Cells(Rows.Count, 4).End(xlUp).Row
            Worksheets("Sheet2").Cells(a + 1, 4).Select
            ActiveSheet.Paste
            Worksheets("Sheet1").Activate
            UITGEVOERDdi = True
        End If
        If SOMdi >= 200 Then
            Worksheets("Sheet1").Cells(Z, 3).Copy
            Worksheets("Sheet2").Activate
            b = Worksheets("Sheet2").Cells(Rows.Count, 4).End(xlUp).Row
            Worksheets("Sheet2").Cells(b + 1, 4).Select
            ActiveSheet.Paste
            Worksheets("Sheet1").Activate
            Z = Z - 1
            Worksheets("sheet1").Cells(Z, 3).Copy
            Worksheets("Sheet2").Activate
            c = Worksheets("Sheet2").Cells(Rows.Count, 5).End(xlUp).Row
            Worksheets("Sheet2").Cells(c + 1, 5).Select
            ActiveSheet.Paste
            Worksheets("Sheet1").Activate
            SOMdi = SOMdi - SOMdi
        End If
    End If
Next Z
         
End Sub

Bekijk bijlage Test1.xlsm <--- VOORBEELD BESTAND
 
Als het om veel gegevens gaat kan je beter werken met array's. Jouw manier van berekenen geeft dubbeltellingen. Probeer het zo eens.
Code: 
Sub VenA()
  Dim b As Boolean, t As Long, t1 As Long, t2 As Long, t3 As Long, ar, ar1
  With Sheets("Sheet1")
    ar = .Cells(1).CurrentRegion
    t = Application.CountIfs(.Columns(2), "x", .Columns(5), ">0")
    ReDim ar1(Application.Sum(.Columns(5)) / 200 + 1, 1)
  End With
  
  For j = 2 To UBound(ar)
    If LCase(ar(j, 2)) = "x" And ar(j, 5) <> "" Then
      t3 = t3 + 1
      If Not b Then
        ar1(t1, 0) = ar(j, 3)
        b = True
        t2 = t2 + ar(j, 5)
       Else
        t2 = t2 + ar(j, 5)
        If t2 > 200 Then
          ar1(t1, 1) = ar(j - 1, 3)
          t1 = t1 + 1
          ar1(t1, 0) = ar(j, 3)
          t2 = t2 - 200 't2 = 0
          'j = j - 1
        End If
      End If
      If t3 >= t Then ar1(t1, 1) = ar(j, 3)
    End If
  Next j
  Sheets("Sheet2").Cells(Rows.Count, 4).End(xlUp).Offset(1).Resize(UBound(ar1), 2) = ar1
End Sub
 
Of:
Code: 
Sub hsv()
Dim sv, arr, i As Long, b As Boolean, n As Long, x As Long
sv = Sheets("sheet1").Cells(1).CurrentRegion
arr = sv
n = 2
For i = 2 To UBound(sv)
  If LCase(arr(i, 2)) = "x" And sv(i, 5) > 0 Then
    If Not b Then
       arr(n - 1, 1) = arr(i, 3)
       b = True
    End If
     x = x + sv(i, 5)
   If x > 200 Or i = UBound(sv) Then
     If n - 2 >= 1 Then arr(n - 1, 1) = arr(n - 2, 2) + 1
        arr(n - 1, 2) = arr(i - 1, 3)
        n = n + 1
        x = sv(i, 5)
     End If
     ElseIf i = UBound(sv) And b Then
        arr(n - 1, 1) = arr(n - 2, 2) + 1
        arr(n - 1, 2) = Sheets("sheet1").Cells(Rows.Count, 5).End(xlUp).Offset(, -2)
    End If
 Next i
 If b Then Sheets("sheet2").Cells(Rows.Count, 4).End(xlUp).Offset(1).Resize(n - 1, 2) = arr
End Sub
 
Dank voor de reactie HSV.

Ik heb u code overgenomen en aan de code één aanpassing verricht. Dit geeft de volgende code:
Code: 
Sub hsv()
Dim sv, arr, i As Long, b As Boolean, n As Long, x As Long
sv = Sheets("sheet1").Cells(1).CurrentRegion
arr = sv
n = 2
For i = 2 To UBound(sv)
    If LCase(arr(i, 2)) = "x" And sv(i, 5) > 0 Then
        If Not b Then
            arr(n - 1, 1) = arr(i, 3)
            b = True
        End If
        x = x + sv(i, 5)
        If x > 200 Then
            If n - 2 >= 1 Then arr(n - 1, 1) = arr(n - 2, 2) + 1
            arr(n - 1, 2) = arr(i - 1, 3)
            n = n + 1
            x = sv(i, 5)
        End If
        If i = UBound(sv) Then
            If n - 2 >= 1 Then arr(n - 1, 1) = arr(n - 2, 2) + 1
            arr(n - 1, 2) = arr(i, 3)
        End If
    ElseIf i = UBound(sv) And b Then
        arr(n - 1, 1) = arr(n - 2, 2) + 1
        arr(n - 1, 2) = Sheets("sheet1").Cells(Rows.Count, 5).End(xlUp).Offset(, -2)
    End If
Next i
If b Then Sheets("sheet2").Cells(Rows.Count, 4).End(xlUp).Offset(1).Resize(n - 1, 2) = arr
End Sub

Nu stuit ik op hetzelfde probleem waar ik aanvankelijk deze topic voor had gemaakt.
Bij het laatste product van groep X wordt het volume van 200 niet behaald. Hierdoor is het de bedoeling dat de eindlocatie van het laatste product van groep X wordt genoteerd.
In de code is terug te zien dat de locatie van de laatste i wordt gepakt op de dinsdag wanneer er wordt voldaan aan de ElseIf statement i = Ubound(sv) and b. Echter zoals in het nieuwe test bestand te zien is, wanneer groep Y onder groep X geplaatst wordt, neemt deze functie de locatie van het laatste product over van groep Y op een dinsdag en niet van groep X.

Is er een mogelijkheid dit probleem te verhelpen?

Voorbeeld bestand: Bekijk bijlage test 2.xlsm
 
Na 3 maanden een reactie waarbij je blijkbaar maar 1 van de suggesties getest hebt. En dan wil je dat wij een voor jou niet zo'n belangrijk probleem opnieuw gaan analyseren? Bijzonder.
 
Ik heb allebei de codes uitvoerig getest en ik ben hier circa twee dagen mee bezig geweest. De code die u stuurde gaf echter een verkeerde output. De laatste pallet overschreed de maximaal toegestane volume van 200 liter. Hierdoor heb ik besloten verder te gaan met de code van HSV. Desalniettemin wordt de input die u heeft geleverd enorm gewaardeerd, ik heb er veel van geleerd.

Daarnaast heb ik door persoonlijke omstandigheden mijn vraag/probleem enkele maanden noodgedwongen moeten laten liggen. Dat neemt niet weg dat ik het probleem niet belangrijk vind.

Om terug te komen op uw opmerking. Ik waardeer uw input en ik heb er veel van geleerd, echter vind ik de conclusie die u trekt niet correct. Ik zou graag, indien mogelijk, een antwoord krijgen op mijn probleem zodat ik hiermee aan de slag kan.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan