Double For Next Loop in a Do While Loop

I

Insomniac83

New Member
Joined
May 22, 2015
Messages
6
Hi everyone,

I have a double For Next loop macro which works flawless, generating stickers with safety hazard symbols for all our products, and being able to print them out on A4 sticker sheets. However, this only works for one product at the time.
Now I want to upgrade this macro/excel sheet with the option to have a picklist where you can send your different product stickers to, and that the macro generates multiple stickers an x number of times underneath each other.
My problem comes when I try to 'rebuild' the macro, adding a Do While loop over a (double?) For Next loop. The Do While loop seems to run just once instead on running trough the picklist. If I move the Do While loop out of the whole code on it's own, it seems to work just fine. Maybe there's some interactions I'm not familiar with.

Hope you guys can help, thanks in advance
Insomniac83

VBA Code: 
Private Sub cmdCreateStickers_Click()
    Dim iRow As Long
    Dim iSticker As Long
    Dim jSticker As Long
    Dim i As Integer
    Dim j As Integer
    Dim r As Integer
    Dim c As Integer
    Dim shB As Worksheet
    Dim shC As Worksheet
    Dim shD As Worksheet
    Dim cRow As Long
    Dim cCol As Long
    Dim nCols As Integer
    Dim runOption As Single
    Dim stickerAmount As Long
    'Dim C As Range
    Dim stickersPerPage As Integer
    Dim Shape As Object
    
        
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationAutomatic
    Application.CopyObjectsWithCells = True
          
    Set shC = Sheets("Stickers")
    Set shD = Sheets("Picklist")
    If shC.Range("formatOptie").Value = 1 Then
        Set shB = Sheets("Stickers 2 x 3")
        stickerAmount = shC.Range("amountToCreate").Value
    ElseIf shC.Range("formatOptie").Value = 2 Then
        Set shB = Sheets("Stickers 3 x 8")
        stickerAmount = shC.Range("amountToCreate").Value
    End If
    
    'remove all stickers
    shB.Select
    ActiveSheet.Cells.Clear
            For Each Shape In ActiveSheet.Shapes
                If Shape.Type = msoPicture Then
                    Shape.Delete
                End If
            Next Shape
    
    'set sticker row heights and column widths based on selected format
    shC.Range("sticker").Cells(1, 1).ColumnWidth = shC.Range("colBwidth").Value
    shC.Range("sticker").Cells(1, 2).ColumnWidth = shC.Range("colCwidth").Value
    shC.Range("sticker").Cells(1, 3).ColumnWidth = shC.Range("colDwidth").Value
    shC.Range("sticker").Cells(1, 4).ColumnWidth = shC.Range("colEwidth").Value
    shC.Range("sticker").Cells(1, 5).ColumnWidth = shC.Range("colFwidth").Value
    shC.Range("sticker").Cells(1, 6).ColumnWidth = shC.Range("CW").Value
    shC.Range("sticker").Cells(1, 1).RowHeight = shC.Range("rowBheight").Value
    shC.Range("sticker").Cells(2, 1).RowHeight = shC.Range("rowCheight").Value
    shC.Range("sticker").Cells(3, 1).RowHeight = shC.Range("rowDheight").Value
    shC.Range("sticker").Cells(4, 1).RowHeight = shC.Range("rowEheight").Value
    shC.Range("sticker").Cells(5, 1).RowHeight = shC.Range("rowFheight").Value
    shC.Range("sticker").Cells(6, 1).RowHeight = shC.Range("rowGheight").Value
    shC.Range("sticker").Cells(7, 1).RowHeight = shC.Range("rowHheight").Value
    shC.Range("sticker").Cells(8, 1).RowHeight = shC.Range("rowIheight").Value
    shC.Range("sticker").Cells(9, 1).RowHeight = shC.Range("rowJheight").Value
    shC.Range("sticker").Cells(10, 1).RowHeight = shC.Range("RH").Value
    
    'shC.Range("sticker").Font.Size = shC.Range("fontSize").Value
    stickersPerPage = Range("stickersPerPage").Value
    
    nCols = shC.Range("nCols").Value
    'reset pictures to avoid becoming corrupt
    shC.Shapes.Range(Array("pictogram1", "pictogram2", "pictogram3", "pictogram4", "pictogram5", "pictogram6")).Height = 33
    shC.Shapes.Range(Array("pictogram1", "pictogram2", "pictogram3", "pictogram4", "pictogram5", "pictogram6")).Width = 33
    shC.Shapes.Range(Array("pictogram1", "pictogram2", "pictogram3", "pictogram4", "pictogram5", "pictogram6")).Top = (Cells(1, 1).Height + Cells(2, 1).Height + 2)
    
    'set column widths
    If shC.Range("formatOptie").Value = 1 Then
         shB.Range("A1").ColumnWidth = shC.Range("sticker").Cells(1, 1).ColumnWidth
         shB.Range("B1").ColumnWidth = shC.Range("sticker").Cells(1, 2).ColumnWidth
         shB.Range("C1").ColumnWidth = shC.Range("sticker").Cells(1, 3).ColumnWidth
         shB.Range("D1").ColumnWidth = shC.Range("sticker").Cells(1, 4).ColumnWidth
         shB.Range("E1").ColumnWidth = shC.Range("sticker").Cells(1, 5).ColumnWidth
         shB.Range("F1").ColumnWidth = shC.Range("sticker").Cells(1, 6).ColumnWidth
         shB.Range("G1").ColumnWidth = shC.Range("sticker").Cells(1, 1).ColumnWidth
         shB.Range("H1").ColumnWidth = shC.Range("sticker").Cells(1, 2).ColumnWidth
         shB.Range("I1").ColumnWidth = shC.Range("sticker").Cells(1, 3).ColumnWidth
         shB.Range("J1").ColumnWidth = shC.Range("sticker").Cells(1, 4).ColumnWidth
         shB.Range("K1").ColumnWidth = shC.Range("sticker").Cells(1, 5).ColumnWidth
    Else
         shB.Range("A1").ColumnWidth = shC.Range("sticker").Cells(1, 1).ColumnWidth
         shB.Range("B1").ColumnWidth = shC.Range("sticker").Cells(1, 2).ColumnWidth
         shB.Range("C1").ColumnWidth = shC.Range("sticker").Cells(1, 3).ColumnWidth
         shB.Range("D1").ColumnWidth = shC.Range("sticker").Cells(1, 4).ColumnWidth
         shB.Range("E1").ColumnWidth = shC.Range("sticker").Cells(1, 5).ColumnWidth
         shB.Range("F1").ColumnWidth = shC.Range("sticker").Cells(1, 6).ColumnWidth
         shB.Range("G1").ColumnWidth = shC.Range("sticker").Cells(1, 1).ColumnWidth
         shB.Range("H1").ColumnWidth = shC.Range("sticker").Cells(1, 2).ColumnWidth
         shB.Range("I1").ColumnWidth = shC.Range("sticker").Cells(1, 3).ColumnWidth
         shB.Range("J1").ColumnWidth = shC.Range("sticker").Cells(1, 4).ColumnWidth
         shB.Range("K1").ColumnWidth = shC.Range("sticker").Cells(1, 5).ColumnWidth
         shB.Range("L1").ColumnWidth = shC.Range("sticker").Cells(1, 6).ColumnWidth
         shB.Range("M1").ColumnWidth = shC.Range("sticker").Cells(1, 1).ColumnWidth
         shB.Range("N1").ColumnWidth = shC.Range("sticker").Cells(1, 2).ColumnWidth
         shB.Range("O1").ColumnWidth = shC.Range("sticker").Cells(1, 3).ColumnWidth
         shB.Range("P1").ColumnWidth = shC.Range("sticker").Cells(1, 4).ColumnWidth
         shB.Range("Q1").ColumnWidth = shC.Range("sticker").Cells(1, 5).ColumnWidth
    End If
    
    'set firstPos in picklist
    shD.Select
    r = 3
        shD.Cells(r, 24) = shD.Range("eerstePos")
        shD.Cells(r, 25) = (shD.Range("eerstePos") + shD.Cells(r, 22)) - 1

    r = 4
    Do While shD.Cells(r, 1) <> ""
        shD.Cells(r, 24) = shD.Cells(r - 1, 25) + 1
        shD.Cells(r, 25) = shD.Cells(r, 22) + shD.Cells(r - 1, 25)
        
        r = r + 1
    Loop
    
    'Begin added Loop
    shD.Select
    c = 3
    Do While shD.Cells(c, 1) <> ""
    shD.Select
            shD.Range(shD.Cells(c, 1), shD.Cells(c, 32)).Copy       '<<Think it goes wrong here
    shC.Select
        shC.Range("DW15:FB15").Select
        ActiveSheet.Paste
        Selection.PasteSpecial Paste:=xlPasteValues 'convert formulas to value
        Application.CutCopyMode = False 'remove from clipboard memory
    
    
    shC.Select
    iSticker = 1
        
    'Begin orginal Loop (just loop many times, when to exit/stop is determined later, not exactly beforehand (This loop = update sticker/ calc. pos. / copy & paste sticker))
    For iRow = 1 To 100000
        
        'increase row number so Excel can calculate values belonging to BatchPicking
        shC.Range("selectRow").Select
        If shC.Range("StickerOptie").Value = 4 Then shC.Range("selectRow").Value = iRow
        
        'Batchpicking: Excel formula tells when to stop. Grondstoffen: stop if stickeramount reached.
        If (shC.Range("createSticker").Value = "STOP") Or (iRow > stickerAmount) Then
            'exit procedure
            shC.Select
            Range("selectRow").Value = 1
            If shC.Range("amountToCreate").Value = 1 Then
                MsgBox "Ready" & vbCrLf & vbCrLf & iSticker - 1 & " sticker has been created.", vbOKOnly + vbInformation, "Create stickers"
                Application.StatusBar = ""
                Application.ScreenUpdating = True
            Else
                MsgBox "Ready" & vbCrLf & vbCrLf & iSticker - 1 & " stickers have been created.", vbOKOnly + vbInformation, "Create stickers"
                Application.StatusBar = ""
                Application.ScreenUpdating = True
            End If
            Exit Sub
        ElseIf shC.Range("createSticker").Value = True Then
            'create sticker (if date=selected date, in case of Batchpicking)
            
            'set left positions of pictograms
            cmdUpdateSticker
                  
            'calculate where to put sticker
            jSticker = iSticker - 1 + (Range("firstPos").Value - 1)
            
            cCol = jSticker Mod nCols
            cRow = WorksheetFunction.RoundDown(jSticker / nCols, 0)
                          
            'copy sticker
            If shC.Range("formatOptie").Value = 1 Then
                shC.Range("sticker").Copy
                shB.Select
                shB.Range("A2").Offset(cRow * 10, cCol * 6).Select
                ActiveSheet.Paste
                Selection.PasteSpecial Paste:=xlPasteValues 'convert formulas to value
                Application.CutCopyMode = False 'remove from clipboard memory
            Else
                shC.Range("sticker").Copy
                shB.Select
                shB.Range("A1").Offset(cRow * 10, cCol * 6).Select
                ActiveSheet.Paste
                Selection.PasteSpecial Paste:=xlPasteValues 'convert formulas to value
                Application.CutCopyMode = False 'remove from clipboard memory
            End If
                        
            If (jSticker Mod stickersPerPage = 0) And (jSticker > 1) Then
            shB.HPageBreaks.Add Before:=Selection.Cells(1, 1)
            End If
            Application.CutCopyMode = False 'remove from clipboard memory
            
            'set row heights, if necessary
            For i = 1 To 10
            
                If shC.Range("formatOptie").Value = 1 Then
                    If shB.Range("A2").Offset(cRow * 10 + i - 1).RowHeight <> shC.Range("sticker").Cells(i, 1).RowHeight Then
                    shB.Range("A2").Offset(cRow * 10 + i - 1).RowHeight = shC.Range("sticker").Cells(i, 1).RowHeight
                    End If
                Else
                    If shB.Range("A1").Offset(cRow * 10 + i - 1).RowHeight <> shC.Range("sticker").Cells(i, 1).RowHeight Then
                    shB.Range("A1").Offset(cRow * 10 + i - 1).RowHeight = shC.Range("sticker").Cells(i, 1).RowHeight
                    End If
                End If
            Next i
                        
            shC.Select
                    
            'show progress
            Application.StatusBar = iSticker
            iSticker = iSticker + 1
            
        End If
    Next iRow   'End orginal Loops
    
    c = c + 1
    
    Loop    'End added Loop
    
            With ActiveSheet.PageSetup
                .PrintTitleRows = ""
                .PrintTitleColumns = ""
                .LeftMargin = Application.CentimetersToPoints(0.65)
                .RightMargin = Application.CentimetersToPoints(0)
                .TopMargin = Application.CentimetersToPoints(0)
                .BottomMargin = Application.CentimetersToPoints(0)
                .HeaderMargin = Application.CentimetersToPoints(0)
                .FooterMargin = Application.CentimetersToPoints(0)
                .PaperSize = xlPaperA4
                .Orientation = xlPortrait 'xlLandscape
                .Zoom = 100
                .FitToPagesWide = 1
                .FitToPagesTall = 1
            End With
    
End Sub
 

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.
Sort by date Sort by votes
I'm not sure if you are familiar with debugging, but it might help to figure out what is going on.
www.excel-easy.com

Debugging in Excel VBA

This example teaches you how to debug code in Excel VBA. By pressing F8, you can single step through your code.
www.excel-easy.com www.excel-easy.com

See if it behaves as expected through the first Do loop, and then pay attention as it begins the second iteration to what c is and the other variables.
 
Upvote 0
When the conditions of the first loop are met, then you end the Sub with:

Exit Sub

You must change it to:

Exit For

I tried to do the test by replicating all the names, sheets and counters.
But the second cycle paste the stickers again in the same position as the first cycle.
Maybe I have some wrong values.
Try and comment.
 
Upvote 0
DanteAmor said:
When the conditions of the first loop are met, then you end the Sub with:

Exit Sub

You must change it to:

Exit For

I tried to do the test by replicating all the names, sheets and counters.
But the second cycle paste the stickers again in the same position as the first cycle.
Maybe I have some wrong values.
Try and comment.
Click to expand...
Hi DanteAmor,

So amazing! That seems to do the trick picklist-wise, it now moves down the picklist and the macro seems to paste different kinds of stickers on the right positions, only not in the right amount of stickers. It takes the value 'amountToCreate' from the last item on the list from the second-to-last run. So if the previous run ended with two stickers, the 'amountToCreate' is set to 2 for to whole next run. Positions of the generated stickers are good though.
The second Do While loop copies data from the picklist. This line that's copied also contains the 'amountToCreate' when it pastes data into the 'Stickers' sheet. Maybe it goes wrong here somewhere?

Have been struggling with this picklist principle for months now and it was one word that needed changing. Thanks so much!
 
Upvote 0
shknbk2 said:
I'm not sure if you are familiar with debugging, but it might help to figure out what is going on.
www.excel-easy.com

Debugging in Excel VBA

This example teaches you how to debug code in Excel VBA. By pressing F8, you can single step through your code.
www.excel-easy.com www.excel-easy.com

See if it behaves as expected through the first Do loop, and then pay attention as it begins the second iteration to what c is and the other variables.
Click to expand...
Hi shknbk2,

I don't have experience with debugging, but I'll have a look into that aswell. Am already one step further. Thanks!
 
Upvote 0
Insomniac83 said:
So if the previous run ended with two stickers, the 'amountToCreate' is set to 2 for to whole next run.
Click to expand...
Your macro is somewhat complex, you have many values to start the process, maybe some will need to be started before starting the next cycle.

So after this line you have to reset the values.

VBA Code: 
    'Begin added Loop
    shD.Select
    c = 3
    Do While shD.Cells(c, 1) <> ""
      'reset some values
      'continue ...
 
Upvote 0
Solution
DanteAmor said:
Your macro is somewhat complex, you have many values to start the process, maybe some will need to be started before starting the next cycle.

So after this line you have to reset the values.

VBA Code: 
    'Begin added Loop
    shD.Select
    c = 3
    Do While shD.Cells(c, 1) <> ""
      'reset some values
      'continue ...
Click to expand...
Good morning DanteAmor,

That did the trick! It appeared that stickerAmount was set to value of previous run a bit up in the code. Resetting to zero and update the stickerAmount after the paste worked. Also, Locals Window showed the value to be set at previous run. Didn't even know something like that existed, very handy!

VBA Code: 
 'Begin added Loop
    shD.Select
    c = 3
    Do While shD.Cells(c, 1) <> ""
    'reset some values
    stickerAmount = 0
    
    'continue
    shD.Select
            shD.Range(shD.Cells(c, 1), shD.Cells(c, 32)).Copy       '<<Think it goes wrong here
    shC.Select
        shC.Range("DW15:FB15").Select
        ActiveSheet.Paste
        Selection.PasteSpecial Paste:=xlPasteValues 'convert formulas to value
        Application.CutCopyMode = False 'remove from clipboard memory
        stickerAmount = shC.Range("amountToCreate").Value

Thank you so much!
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question Question
Loop through each file in folder and perform an action
Replies
0
Views
599
Monsieur Roo
M
N
  • Solved
VBA - Do Until Loop is Not Looping
Replies
9
Views
1K
Joe4
Joe4
P
  • Question Question
Do while Loop, and For next can use together in sheets?
Replies
1
Views
455
Joe4
Joe4
P
  • Question Question
VBA to create proposal sheet(s)
Replies
3
Views
1K
padadof2
P
O
  • Solved
Cannot get get While or Do loop to do the simple task required. End up with endless looping. I'm missing something basic.
Replies
6
Views
426
smozgur
smozgur

Forum statistics

Threads
1,223,888
Messages
6,175,205
Members
452,618
Latest member
Tam84

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top