Need help on how to loop this

[butters149]

Hello,

I am fairly new to this. What I'm trying to do is find the header and start the copying from there, then copy it to a new worksheet and rename the worksheet with a defined cell in that same worksheet. Then I go back and find the next same header and copy from there to the end of that table, then paste to new worksheet and repeat until all are found. below is my vba.

Sub Macro1()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+g
'
'Find header, copy and paste to new worksheet
Cells.Find(What:="unique header", After:= _
ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False).Activate
Range(ActiveCell, ActiveCell.Offset(, 2)).Select
Range(Selection, Selection.End(xlDown)).Select


Selection.Copy
Sheets.Add After:=ActiveSheet
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Range("A1:M1").Select


'Rename Worksheet
ActiveSheet.Name = Range("A2")

'Reset
Sheets("Matter Summary").Select
Application.CutCopyMode = False
SendKeys "{down}"

'Reset1
'Find header, copy and paste to new worksheet
Cells.Find(What:="unique header", After:= _
ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False).Activate
Range(ActiveCell, ActiveCell.Offset(, 2)).Select
Range(Selection, Selection.End(xlDown)).Select


Selection.Copy
Sheets.Add After:=ActiveSheet
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Range("A1:M1").Select


'Rename Worksheet
ActiveSheet.Name = Range("A2")

'Reset
Sheets("Matter Summary").Select
Application.CutCopyMode = False
SendKeys "{down}"
End Sub

 

[butters149]

As I understand it, you have several cells in column A that contain "Header" with varying rows in between.
You want to find the cells between each of those cells, extend that range out to column M and do something to that extended range.
AND you want to loop through all such ranges until you reach the end of column A.

Try this:
First write a routine that processes each single attorney range when given that range.

Then code like this will do the looping

Sub test()
    Dim startCell As Range
    Dim endCell As Range
    Dim foundCell As Range
    Dim thisChunk As Range
    Dim firstFoundAddress As String
    
    With Sheet1.Range("A:A")
        Set foundCell = .Find("Header", after:=.Cells(Rows.Count, 1), LookIn:=xlValues, _
                                    LookAt:=xlWhole, searchdirection:=xlNext, MatchCase:=True)
    
        If foundCell Is Nothing Then MsgBox "no header": Exit Sub
        
        firstFoundAddress = foundCell.Address
        Set startCell = foundCell
        
        Do
            Set foundCell = .FindNext(after:=foundCell)
            If foundCell.Address = firstFoundAddress Then
                Set endCell = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
            Else
                Set endCell = foundCell
            End If
            
            Set thisChunk = Range(startCell, endCell.Offset(-1, 0)).Resize(, Range("M1").Column)
            
            Call ProcessOneChunk(thisChunk)
            
            Set startCell = endCell
        Loop Until foundCell.Address = firstFoundAddress
    End With
End Sub

Sub ProcessOneChunk(aRange As Range)
    MsgBox "This chunk is " & aRange.Address
End Sub

this returned no header. The first header is actually from A1 to M1 since it uses the Merge command. The table extends from A to O.

 

[mikerickson]

Did you adjust the sheet reference to match your situation?

' my code

 With Sheet1.Range("A:A")


'other options
With ThisWorkbook.Sheets("sheetName").Range("A:A")

Also, I'm not sure how merged cells would work with the .Find method. Most people avoid Merged cells like the plague. The CenterAcrossSelection (in Horizontal Alignment) is much better.

 

[butters149]

I did adjust it with regards to the header and range.

Did you adjust the sheet reference to match your situation?

' my code

 With Sheet1.Range("A:A")


'other options
With ThisWorkbook.Sheets("sheetName").Range("A:A")

Also, I'm not sure how merged cells would work with the .Find method. Most people avoid Merged cells like the plague. The CenterAcrossSelection (in Horizontal Alignment) is much better.

 

[mikerickson]

And your header is actually "Header", case sensitive with no trailing space?

 

[My Aswer Is This]

I'm just curious. How many of these new sheets will we be making?
Are you talking maybe 5 or 6 on 10 to 30

I always like using Tables.

If you were to give each Lawyer his own Table. And name each Table1 then Table2 and then Table3 etc.

We could setup a loop which would loop through each Table like from Table1 to Table10 or Table5 to Table 10.

If this is going to be a on going project you will be working with for years it looks to me this would be a good way to do things.

This way no matter where the Table is located on the sheet or how wide or long the table is the script would work.

The script would copy the TableRange. So no matter how wide or long the Table is the script copies the entire table.

Just my thoughts.