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

我试图在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

Sub-TryThis（）
将最后一行设置为整数
暗淡的startcell As范围
暗端细胞
图纸（“图纸1”）。选择
LastRow=ActiveSheet.Range（“A1000000”）.End（xlUp）.Row
设置startrng=范围（“A1:A”和LastRow）
对于工作表（1）.Range（startrng.Address&“：”&Cells（LastRow，startrng.Column.Address）”我建议在循环中使用
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

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