Do Loop Until.. Then continue loop where it is left

[Akbarov]

Hello,

I am trying to copy paste range with 2 criteria. Following VBA finds
startrow = if row is grey
and
endrow = if cell value starts with "Somme ligne"
and copy it to a new workbook and saves it.

But it stops at first match and saves workbook
So startrow = 4 and endrow = 13

I want to make it loop after row 13 and repeat same steps. To find next grey and word "Somme ligne"
Can anyone help me please? sharing workbook in attachment, may be that will be more clear.

Book8.xlsx

Shared with Dropbox

www.dropbox.com

   Dim rownum As Long
   Dim colnum As Long
   Dim startrow As Long
   Dim endrow As Long
   Dim lastrow As Long
   Dim wb As Workbook
   Dim ws As Worksheet
   rownum = 1
   colnum = 3
   lastrow = ActiveSheet.Range("C65536").End(xlUp).Row
  
   Set wb = ThisWorkbook
   Set ws = wb.Sheets("Main")
  
    With ws.Range("c1:c" & lastrow)
    

   For rownum = 1 To lastrow
    Do
       If Range(Cells(rownum, 3), Cells(rownum, 3)).Interior.Color = RGB(191, 191, 191) Then
          startrow = rownum + 1
       End If

       rownum = rownum + 1


   If (rownum > lastrow) Then Exit For

   Loop Until Left(Range(Cells(rownum, 4), Cells(rownum, 4)).Value, 11) = "Somme ligne"
   endrow = rownum
   rownum = rownum + 1

   'ActiveSheet.Range(Cells(startrow, 2), Cells(endrow, 17)).Copy

'///////////////////////////////////////////////////////////////////////////////////////////
   'Sheets("Result").Select
   'Range("A1").Select
   'ActiveSheet.Paste
'///////////////////////////////////////////////////////////////////////////////////////////
    Dim wbO As Workbook
    Dim wsO As Worksheet
       '~~> Destination/Output Workbook
    Set wbO = Workbooks.Add
    DoEvents
    With wbO
        '~~> Set the relevant sheet to where you want to paste
        Set wsO = wbO.Sheets("Sheet1")

        '~~>. Save the file
        .SaveAs Filename:="C:\Users\MC\Downloads\Output.xls", FileFormat:=56
        DoEvents
        '~~> Copy the range
        ws.Range(Cells(startrow, 2), Cells(endrow, 17)).Copy

        '~~> Paste it
        wsO.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    End With


   Next rownum
   End With

 

[offthelip]

try this modification:

Dim rownum As Long
   Dim colnum As Long
   Dim startrow As Long
   Dim endrow As Long
   Dim lastrow As Long
   Dim wb As Workbook
   Dim ws As Worksheet
   rownum = 1
   colnum = 3
   lastrow = ActiveSheet.Range("C65536").End(xlUp).Row
 
   Set wb = ThisWorkbook
   Set ws = wb.Sheets("Main")
 
    With ws.Range("c1:c" & lastrow)
  

   For rownum = 1 To lastrow
  
       If Range(Cells(rownum, 3), Cells(rownum, 3)).Interior.Color = RGB(191, 191, 191) Then
          startrow = rownum + 1
       End If
        If Left(Range(Cells(rownum, 4), Cells(rownum, 4)).Value, 11) = "Somme ligne" Then
        endrow = rownum
        Exit For
        End If
       ' rownum = rownum + 1 ' I presume you wnat to check every row not every other row so I have commented this out
       
 
     Next rownum

   'ActiveSheet.Range(Cells(startrow, 2), Cells(endrow, 17)).Copy

'///////////////////////////////////////////////////////////////////////////////////////////
   'Sheets("Result").Select
   'Range("A1").Select
   'ActiveSheet.Paste
'///////////////////////////////////////////////////////////////////////////////////////////
    Dim wbO As Workbook
    Dim wsO As Worksheet
       '~~> Destination/Output Workbook
    Set wbO = Workbooks.Add
    DoEvents
    With wbO
        '~~> Set the relevant sheet to where you want to paste
        Set wsO = wbO.Sheets("Sheet1")

        '~~>. Save the file
        .SaveAs Filename:="C:\Users\MC\Downloads\Output.xls", FileFormat:=56
        DoEvents
        '~~> Copy the range
        ws.Range(Cells(startrow, 2), Cells(endrow, 17)).Copy

        '~~> Paste it
        wsO.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    End With


   End With

 

[Akbarov]

Thank you for reply and time, I tested your code but seems it is not working.

But I found a solution

I added LoopStart: above Do

LoopStart:

    Do

And made little change at the end , now it works.

 startrow = endrow + 1
    rownum = rownum - 1
    ws.Activate
   Next rownum
   End With
 
   GoTo LoopStart:
  
   End Sub