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

 

[My Aswer Is This]

Would you not like to tell us what your ultimate Goal is?

Are you wanting to copy the headers in row (1) and paste to row (1) of a new sheet?

And name the new sheet by the name in Range("A2")

We could do this all at once only needing to run the script once.

What are the names you want to give to these new sheets?
And we are copying the headers from a sheet named

Matter Summary​

 

[butters149]

Would you not like to tell us what your ultimate Goal is?

Are you wanting to copy the headers in row (1) and paste to row (1) of a new sheet?

And name the new sheet by the name in Range("A2")

We could do this all at once only needing to run the script once.

What are the names you want to give to these new sheets?
And we are copying the headers from a sheet named

Matter Summary​

Basically the spreadsheet contains the following information

Header A1
Attorney Name A2
Attorney information in table format, so range can be like A5 to M5 and then down to rows 23 (this can change depending on attorney)
*Select all of this, copy and paste into new worksheet with worksheet name referred to cell in A2 of new worksheet.

Header A24
Attorney Name A25
Table content
*Select all of this, copy and paste into new worksheet with worksheet name referred to cell in A2 of new worksheet.
etc etc

Does this make more sense? I am basically using the format of Header as a trigger to start a new copy of the information.

 

[My Aswer Is This]

Do all your tables have names like Table1 then Table2 and so on?

Could we not just copy Table1 to Sheets(2) and Then Table2 to Sheet(3)

And so on.

If so how many Tables do you have on sheet named Matter Summary

And on the second row of each table you have a name in Column "A" which will be our new sheet name.


Would this work?

 

[mikerickson]

Does the second attorney always start at row 25, and the next at row 49, etc.
Or do the number of rows per attorney vary depending on the amount of information in A3:M??

 

[butters149]

Does the second attorney always start at row 25, and the next at row 49, etc.
Or do the number of rows per attorney vary depending on the amount of information in A3:M??

The number of rows vary. The only constant i was trying to refer to via "find" was the header. Which is unique and I want as the header of the new worksheet anyways.

There are no table names to refer to.

 

[My Aswer Is This]

So how are we to know how wide or long the Table is?

In post one you said:

Then I go back and find the next same header and copy from there to the ​

end of that table

Does each range go from Column A to M?
​

 

[butters149]

So how are we to know how wide or long the Table is?

In post one you said:

Then I go back and find the next same header and copy from there to the ​

end of that table

Does each range go from Column A to M?
​

Wide is fixed at A-M and that is why in the first part of the VBA i did the below code. But the length varies and it depends on me using the controls ctrl, shift, down to end of table.

Range(ActiveCell, ActiveCell.Offset(, 2)).Select

 

[My Aswer Is This]

Normally when we are writing a script using a loop we do not like using active cell.

Normally we would say something like

Range(A1:M40")

 

[mikerickson]

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