Question

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

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

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

编辑：我正在使用Excel 2013。不确定是否重要但删除空白列后，RANK部分中的列数为12，PLACE部分中的列数为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

Answer 1

从网址导入的表格＆＃39;通常有一个标题行，虽然它们可能有单独的空白单元格，但数据矩阵中通常没有完整的空白行或列。这使得它们成为Range.CurrentRegion property引用的理想选择。 split_Rank_Places应该适用于那些人。

如果表中有空行，则需要使用不同的方法来确定表的大小。在这些情况下，split_Rank_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

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

选择单词和空白行之间的范围，然后移至新工作表

1 个答案: