VBA Macro help

[Balmung]

Hey all,

I've been trying to edit a script that someone helped me get started with but I'm a bit stuck on how to choose ranges automatically based on when there's a cell in column A that has data. A little background: I have page headers and information in rows 1-3 that I don't need to grab. Row 4 has a header that I'm going to transfer to each new tab I need to make (which I believe I can do) but after that, starting on row 5, there are basically categories that are merged cells (the one I have right now has Cancel starting at row 5 going down to row 169). Then there are Endorse, New, NonRenew, Reinstate, Renew, and VoidFinalAudit. There's also a total row at the bottom of the spreadsheet but that isn't necessary to use. From the start I've had, I can get it to copy everything in the Cancel section and paste it onto Sheet1 (which is basically tab 2 but the first tab has another name from when it's exported) and I've made it so it can grab Endorse as well for Sheet2 but I don't think it's as consolidated as it can be.

Each category's section will change each time the report is ran and exported, so I'm not sure how to grab the ranges without manually changing numbers in the code. Can anyone look over what I have now and give suggestions or help me out? I'm not that great with VBA since I'm basically just starting with it.

Sub Test1()

Dim myFind As String
Dim myRng As Range

myFind = Worksheets("RTW Policy Exchange Detail.rdl").Range("A5").Value

With Worksheets("RTW Policy Exchange Detail.rdl").Range("5:169")
    Set myRng = .Find(What:=myFind, After:=.Cells(.Cells.Count), LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
            
    
            
    If Not myRng Is Nothing Then
        Application.Goto myRng, True
    Else: End If
    
    
    Range(Selection, "O" & Selection.Row).Select

End With

Worksheets("RTW Policy Exchange Detail.rdl").Range("5:169").Copy _
Destination:=Worksheets("Sheet1").Range("A2")

With Worksheets("Sheet1")
    Worksheets("Sheet1").Columns("N:O").ColumnWidth = 50
    Worksheets("Sheet1").Columns("H:L").ColumnWidth = 10
    Worksheets("Sheet1").Rows("1:500").RowHeight = 12.75
End With

ActiveCell.Offset(1, 0).Range("A5").Select

myFind = Worksheets("RTW Policy Exchange Detail.rdl").Range("A170").Value

With Worksheets("RTW Policy Exchange Detail.rdl").Range("170:251")
    Set myRng = .Find(What:=myFind, After:=.Cells(.Cells.Count), LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
            
    
            
    If Not myRng Is Nothing Then
        Application.Goto myRng, True
    Else: End If
    
    
    Range(Selection, "O" & Selection.Row).Select

End With

Worksheets("RTW Policy Exchange Detail.rdl").Range("170:251").Copy _
Destination:=Worksheets("Sheet2").Range("A2")

With Worksheets("Sheet2")
    Worksheets("Sheet2").Columns("N:O").ColumnWidth = 50
    Worksheets("Sheet2").Columns("H:L").ColumnWidth = 10
    Worksheets("Sheet2").Rows("1:500").RowHeight = 12.75
End With

End Sub

 

[pbornemeier]

One of the following words: Cancel, Endorse, New, NonRenew, Reinstate, Renew, and VoidFinalAudit occupies contiguous merged cells in column A.
One Block of cells, currently looking at cancel, occupies the merged cells from A5:A169.
Copy the rows of that entire block to another worksheet starting at row 2
The header for all copied worksheets is row 4 from the main worksheet
Make a new worksheet for the rows of each block

If the above statements are correct, I believe this code will do what you want:

Option Explicit

Sub CopyColumnABlockRowsToNewWorksheet()

    Dim varSections As Variant
    Dim lX As Long
    Dim oFound As Object
    Dim sWorksheet As String
    
    varSections = Array("Cancel", "Endorse", "New", "NonRenew", "Reinstate", "Renew", "VoidFinalAudit")
    
    For lX = LBound(varSections) To UBound(varSections)
        Set oFound = Worksheets("RTW Policy Exchange Detail.rdl").Columns(1).Find(What:=varSections(lX), _
            LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
        If Not oFound Is Nothing Then
        
            'Delete/Create Target worksheet
            sWorksheet = varSections(lX)
            On Error Resume Next
            Application.DisplayAlerts = False
            Worksheets(sWorksheet).Delete
            Application.DisplayAlerts = True
            On Error GoTo 0
            Worksheets.Add(After:=Sheets(Sheets.Count)).Name = sWorksheet 'After last
        
            'Copy Found Rows
            oFound.MergeArea.EntireRow.Copy _
                Destination:=Worksheets(sWorksheet).Range("A2")
            'Copy Headers
            Worksheets("RTW Policy Exchange Detail.rdl").Rows(4).Copy _
                Destination:=Worksheets(sWorksheet).Range("A1")
            'Format New Worksheet
            With Worksheets(sWorksheet)
                .Columns("N:O").ColumnWidth = 50
                .Columns("H:L").ColumnWidth = 10
                .UsedRange.RowHeight = 12.75
                
                'Freeze Top Row
                With ActiveWindow
                    .SplitColumn = 0
                    .SplitRow = 1
                End With
                ActiveWindow.FreezePanes = True
            End With
 
        End If
    
    Next

    Set oFound = Nothing

End Sub