Excel 选择单词和空行之间的范围并移动到新工作表

我已将表从URL导入到表1中。有两种类型的表，每次导入时表的数量可能会有所不同。表1以A列中的单词RANK开始，以2个空行结束。表2以A列中的单词PLACE开头，以两个空行结尾。行数每次也会有所不同，但列数始终不变

我需要选择每个表/部分，将所有表1放在一张纸上，将所有表2放在一张单独的纸上，中间有两个空行

似乎我能找到的唯一信息是人们希望删除空行或在第一个空行中粘贴某些内容。我希望这里有人能帮助我

编辑：我正在使用Excel 2013。 不确定它是否重要，但是删除空白列之后，秩部分中的列数为12，并且位置部分中的列数为7。 这是我正在使用的代码

Sub Test_1()
'
' Test_1 Macro
'

'
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;https://www.RandomSite/id_6264", Destination:=Range("$A$1"))
        .Name = "6264"
        .Application.ScreenUpdating = False
        .Application.Calculation = xlCalculationManual
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlAllTables
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    Rows("1:2").Select
    Selection.Delete Shift:=xlUp
    Columns("A:A").Select
    Selection.NumberFormat = "@"
   ' Dimension variables.
   Y = False              ' Change this to True if you want to
                          ' delete rows 1, 3, 5, and so on.
   I = 1
   Set xRng = Selection

   ' Loop once for every row in the selection.
   For xCounter = 1 To xRng.Rows.Count

       ' If Y is True, then...
       If Y = True Then

           ' ...delete an entire row of cells.
           xRng.Cells(I).EntireRow.Delete

       ' Otherwise...
       Else

           ' ...increment I by one so we can cycle through range.
           I = I + 1

       End If

       ' If Y is True, make it False; if Y is False, make it True.
       Y = Not Y

   Next xCounter
      ' Dimension variables.
   Y = True              ' Change this to True if you want to
                          ' delete columns 1, 3, 5, and so on.
   I = 1
   Set xRng = Selection

   ' Loop once for every column in the selection.
   For xCounter = 1 To xRng.Columns.Count

       ' If Y is True, then...
       If Y = True Then

           ' ...delete an entire column of cells.
           xRng.Cells(I).EntireColumn.Delete

       ' Otherwise...
       Else

           ' ...increment I by one so we can cycle through range.
           I = I + 1

       End If

       ' If Y is True, make it False; if Y is False, make it True.
       Y = Not Y

   Next xCounter

End Sub

---

从“URL”导入的表通常有一个标题行，虽然它们可能有单独的空白单元格，但数据矩阵中通常没有完整的空白行或列。这使它们非常适合作为参考。

split\u-Rank\u-Places

应该适合这些人

如果表中有空行，则需要使用不同的方法确定表的大小。在这些情况下，

split\u Rank\u Places2

是合适的

Sub split_Rank_Places()
    Dim v As Long, vTBLs As Variant
    Dim fnd As Range

    On Error GoTo bm_Safe_Exit
    appTGGL bTGGL:=False
    vTBLs = Array("PLACE", "a sheet", _
                  "RANK", "a separate sheet")

    With Worksheets("sheet 1")
        For v = LBound(vTBLs) To UBound(vTBLs) Step 2
            On Error Resume Next
            Worksheets(vTBLs(v + 1)).Delete
            On Error GoTo bm_Safe_Exit
            .Copy After:=Worksheets(.Index)
            With Worksheets(.Index + 1)
                .Name = vTBLs(v + 1)
                With .Columns(1)
                    On Error Resume Next
                    Set fnd = .Find(What:=vTBLs(v), LookIn:=xlValues, _
                                    LookAt:=xlWhole, SearchOrder:=xlByColumns, _
                                    SearchDirection:=xlNext, MatchCase:=True)
                    Do While Not fnd Is Nothing
                        With fnd.CurrentRegion
                            With .Resize(.Rows.Count + 2, 1)
                                .EntireRow.Delete
                            End With
                        End With
                        Set fnd = .FindNext(After:=.Cells(1))
                    Loop
                    On Error GoTo bm_Safe_Exit
                End With
            End With
        Next v
    End With

bm_Safe_Exit:
    appTGGL

End Sub

Sub split_Rank_Places2()
    Dim v As Long, vTBLs As Variant
    Dim fnd As Range, stp As Long

    On Error GoTo bm_Safe_Exit
    appTGGL bTGGL:=False
    vTBLs = Array("RANK", "PLACE", "a sheet", _
                  "PLACE", "RANK", "a separate sheet")

    With Worksheets("sheet 1")
        For v = LBound(vTBLs) To UBound(vTBLs) Step 3
            On Error Resume Next
            Worksheets(vTBLs(v + 2)).Delete
            On Error GoTo bm_Safe_Exit
            .Copy After:=Worksheets(.Index)
            With Worksheets(.Index + 1)
                .Name = vTBLs(v + 2)
                With .Columns(1)
                    On Error Resume Next
                    Set fnd = .Find(What:=vTBLs(v + 1), LookIn:=xlValues, _
                                    LookAt:=xlWhole, SearchOrder:=xlByColumns, _
                                    SearchDirection:=xlNext, MatchCase:=True)
                    Do While Not fnd Is Nothing
                        If CBool(Application.CountIf(fnd.Resize(Rows.Count - fnd.Row, 1), vTBLs(v))) Then
                            stp = Application.Match(vTBLs(v), fnd.Resize(Rows.Count - fnd.Row, 1), 0)
                            fnd.Resize(stp - 1, 1).EntireRow.Delete
                        Else
                            fnd.Resize(Rows.Count - fnd.Row, 1).EntireRow.Delete
                        End If
                        Set fnd = .FindNext(After:=.Cells(1))
                    Loop
                End With
            End With
        Next v
    End With

bm_Safe_Exit:
    appTGGL

End Sub


Sub appTGGL(Optional bTGGL As Boolean = True)
    Application.ScreenUpdating = bTGGL
    Application.EnableEvents = bTGGL
    Application.DisplayAlerts = bTGGL
    Application.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
End Sub

---

有时候，摆脱你不想要的东西比尝试复制你想要的东西更容易。

为什么不直接将表格从“URL”导入“工作表”和“单独的工作表”？我尝试过，但始终没有成功。对我来说，使用xlAllTables更容易。由于表的数量不同，我认为我的选择是导入所有表或指定每次需要手动输入的表（1、2、4等）。如果我错了，请纠正我。我必须有一种不典型的情况，因为当我导入其他每一行和每一列时都是空白的。我运行了一个宏来删除所有的空白，但这就是我目前所能找到的。另外，谢谢你的帮助。我刚刚运行了你的代码，我得到了一个“编译错误”。未定义子或函数。这是选中的：appTGGLIt似乎没有复制我在post.Oops底部包含的伴随

子appTGGL

过程。我已将该过程添加到底部，并再次运行宏。我第一次运行它时，创建了“一张工作表”和“一张单独的工作表”，但没有从工作表1中移动任何内容。我认为这与我添加新过程有关，所以我退出Excel，重新打开项目，再次运行宏。这一次，我没有得到任何工作。我没有得到任何错误，但我也没有得到任何图纸创建。