Trying to copy/paste and transpose multiple ranges between a start points and end points

Question

I am trying to loop through cells in ColumnA to find a start point and end point, then copy all rows between these anchors, transpose the data set, and then continue looping through the rest of the cells and do the same.

I came up with this, but I know it's not even close to working.

Sub TryThis()   
    Dim LastRow As Integer
    Dim startcell As Range
    Dim endcell As Range
    
    Sheets("Sheet1").Select
    LastRow = ActiveSheet.Range("A1000000").End(xlUp).Row
    
    Set startrng = Range("A1:A" & LastRow)
    
    With Worksheets(1).Range(startrng.Address & ":" & Cells(LastRow, startrng.Column).Address) '<== set the start search range here
        Set startcell = .Find(What:="class: pipestandardize.Standardize")
    End With
        
    With Worksheets(1).Range(startcell.Address & ":" & Cells(LastRow, startcell.Column).Address) '<== set the end search range here
        Set endcell = .Find(What:="id: standardize")
    End With
    
    
    ' Range("A10:A100,A150:A330,A380:A420").Select
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A1").End(xlUp).Select
    lMaxRows = Cells(Rows.Count, "A").End(xlUp).Row
    Range("A" & lMaxRows + 1).Select
    
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    
    Sheets("Sheet1").Select 
End Sub

Basically, I want to select all rows from the starting point of class: pipestandardize.Standardize to the ending point of id: standardize, copy this range, and transpose it and paste it.

Then, from the cell after id: standardize, start looping through cells again, to find the next starting point that contains class: pipestandardize.Standardize and go down to the ending point that contains id: standardize, select this range, copy and transpose/paste under the previous one.

Pᴇʜ Pᴇʜ · Accepted Answer · 2018-10-19T07:46:48

I suggest using Find in a loop, and exit the loop either if it finds no start/end anymore or if finished.

Option Explicit

Public Sub TransposeData()
    Dim wsSrc As Worksheet
    Set wsSrc = ThisWorkbook.Worksheets("Sheet1")

    Dim wsDest As Worksheet
    Set wsDest = ThisWorkbook.Worksheets("Sheet2")

    Dim SearchRange As Range 'define search range
    Set SearchRange = wsSrc.Range("A1", wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp))

    Dim LastRowDest As Long
    LastRowDest = wsDest.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row

    Dim StartRange As Range, EndRange As Range
    Set EndRange = SearchRange(1, 1) 'initialize

    Application.ScreenUpdating = False

    Do
        Set StartRange = Nothing
        On Error Resume Next
        Set StartRange = SearchRange.Find(What:="class: pipestandardize.Standardize", After:=EndRange, LookAt:=xlWhole)
        On Error GoTo 0
        If StartRange Is Nothing Then Exit Do 'stop if start not found
        If StartRange.Row < EndRange.Row Then Exit Do 'stop if find started again from beginning

        Set EndRange = Nothing
        On Error Resume Next
        Set EndRange = SearchRange.Find(What:="id: standardize", After:=StartRange, LookAt:=xlWhole)
        On Error GoTo 0
        If EndRange Is Nothing Then Exit Do

        LastRowDest = LastRowDest + 1
        wsSrc.Range(StartRange, EndRange).Copy
        wsDest.Cells(LastRowDest, "A").PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=True

        DoEvents 'keep Excel responsive
    Loop

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Note that Find will throw an error if it finds nothing. So we need to catch that error:

Set StartRange = Nothing 'reset StartRange 
On Error Resume Next 'hide all error messages
Set StartRange = SearchRange.Find(What:="class: pipestandardize.Standardize", After:=EndRange, LookAt:=xlWhole)
'if find throws an error it is hidden now
On Error GoTo 0 're-enable error reporting!!!

'if find didn't didn't find anything then StartRange is still Nothing
If StartRange Is Nothing Then Exit Do 'stop if start not found

Trying to copy/paste and transpose multiple ranges between a start points and end points

1 Answers