在宏中选择一个字段并在循环中将其剪切掉

Question

我需要在Excel工作表中选择一个单元格字段（表格），剪切选择，然后将其粘贴到一个新的单独工作表中。在这个工作表中，有几千个表彼此相同，我想自动剪切它们并将它们粘贴到单独的工作表中。表格由带有＃符号的单元格分隔，但我不知道它是否有用。当我为第一个表录制这个宏时，它运行如下：

Sub Makro1()
Range("A2:AB20").Select
Selection.Cut
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
End Sub

现在我想创建一个遍历整个工作表的循环，动态选择将由col A中的＃符号分隔的每个表并将其粘贴到新表中。我不想选择确切的范围A2：AB20，但我想根据这个＃符号进行选择。

这是截图

Answer 1

这将使用所有哈希值的索引填充数组。这应该为您提供收集适当数据所需的参考点。

Sub FindHashmarksInColumnA()

    Dim c As Range
    Dim indices() As Long
    Dim i As Long
    Dim iMax As Double
    Dim ws As Worksheet

    Set ws = ActiveSheet

    i = 0
    iMax = Application.WorksheetFunction.CountIf(ws.Range("A:A"), "#")
    ReDim indices(1 To iMax)

    For Each c In ws.UsedRange.Columns(1).Cells
        If c.Value = "#" Then
            i = i + 1
            indices(i) = c.Row
        End If
    Next c

    ' For each index,
    ' Count rows in table,
    ' Copy data offset from reference of hashmark,
    ' Paste onto new sheet in appropriate location etc.

End Sub

Answer 2

试试这段代码。您可能需要根据需要调整前4个常量：

Sub CopyToSheets()
    Const cStrSourceSheet As String = "tabulky"
    Const cStrStartAddress As String = "A2"
    Const cStrSheetNamePrefix As String = "Result"
    Const cStrDivider As String = "#"

    Dim rngSource As Range
    Dim lngMaxRow As Long, lngLastDividerRow As Long, lngRowCount As Long
    Dim wsTarget As Worksheet
    Dim lngCounter As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    'Delete old worksheets
    Application.DisplayAlerts = False
    For Each wsTarget In Sheets
        If InStr(wsTarget.Name, cStrSheetNamePrefix) Then wsTarget.Delete
    Next
    Application.DisplayAlerts = True

    With Sheets(cStrSourceSheet)
        Set rngSource = .Range(cStrStartAddress)
        lngLastDividerRow = rngSource.Row
        lngMaxRow = .Cells(Rows.Count, 1).End(xlUp).Row
    End With

    Set rngSource = rngSource.Offset(1)
    While rngSource.Row < lngMaxRow
        If rngSource = cStrDivider Then
            lngCounter = lngCounter + 1
            Set wsTarget = Sheets.Add(After:=Sheets(Sheets.Count))
            wsTarget.Name = cStrSheetNamePrefix & " " & lngCounter
            lngRowCount = rngSource.Row - lngLastDividerRow - 1
            rngSource.Offset(-lngRowCount - 1).Resize(lngRowCount).EntireRow.Copy _
                wsTarget.Range("A1").Resize(lngRowCount).EntireRow

            lngLastDividerRow = rngSource.Row
        End If
        Set rngSource = rngSource.Offset(1)
    Wend

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub