Question

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

我想到了这个，但我知道它甚至还差得远。

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的终点，选择在此范围内，复制并转置/粘贴上一个。

这里的VBA专家可以帮助我吗？

我可以提供一些屏幕截图，但我认为我的描述可以说明这一点。

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

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

1 个答案: