尝试在起点和终点之间复制/粘贴和转置多个范围

Question

我正在尝试遍历 ColumnA 中的单元格以找到起点和终点，然后复制这些锚点之间的所有行，转置数据集，然后继续遍历其余单元格并执行相同操作。

我想出了这个，但我知道它甚至还没有接近工作。

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

基本上，我想选择从class: pipestandardize.Standardize的起点到id: standardize的终点的所有行，复制这个范围，然后转置粘贴。

然后，从id: standardize之后的单元格开始，再次开始循环遍历单元格，找到下一个包含class: pipestandardize.Standardize的起点，下到包含id: standardize的终点，选择这个范围，复制转置/粘贴在前一个下。

Answer 1

我建议在循环中使用Find，如果找不到开始/结束或结束，则退出循环。

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

请注意，Find 如果什么也没找到，会抛出错误。所以我们需要捕获那个错误：

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