从VBA复制范围中排除1行

Question

我正在编写一些代码，将形成单独零件清单的多个工作表合并为一个大的零件清单。

到目前为止，我有两个函数扫描每个工作表的最后一行和最后一列。

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
                        After:=sh.Range("A1"), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
    On Error GoTo 0
End Function

并且

Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
                        After:=sh.Range("A1"), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column
    On Error GoTo 0
End Function

我随后有另一个子程序，创建了一个名为“零件清单”（Parts List）的新工作表，并将范围粘贴在那里。

Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

' Delete the summary sheet if it exists.
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Parts List").Delete
On Error GoTo 0
Application.DisplayAlerts = True

' Add a new summary worksheet.
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Parts List"


' Loop through all worksheets and copy the data to the
' summary worksheet.
For Each sh In ActiveWorkbook.Worksheets
    If sh.Name <> DestSh.Name Then

        ' Find the last row with data on the summary worksheet.
        Last = LastRow(DestSh)

        ' Specify the range to place the data.
        ' Set CopyRng = sh.Range("B3:G10").
        Set CopyRng = sh.UsedRange

        ' Test to see whether there are enough rows in the summary
        ' worksheet to copy all the data.
        If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
            MsgBox "There are not enough rows in the " & _
               "summary worksheet to place the data."
            GoTo ExitTheSub
        End If

        ' This statement copies values and formats from each
        ' worksheet.
        CopyRng.Copy
        With DestSh.Cells(Last + 1, "A")
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
            Application.CutCopyMode = False
        End With

        ' Optional: This statement will copy the sheet
        ' name in the H column.
        DestSh.Cells(Last + 1, "I").Resize(CopyRng.Rows.Count).Value = sh.Name

    End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

' AutoFit the column width in the summary sheet.
DestSh.Columns.AutoFit

With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With
End Sub

我遇到的问题是标题行也被复制了。有人知道如何在扫描行和列或复制时排除标题吗？

谢谢任何帮助 丹

- Dan M

---

标题行是否固定在位置上，或者它们的单元格类型不同？例如，文本与数字？如果您分享一下您的工作表的外观，那将会很有帮助。 - Luuklag

我已经添加了零件清单的图像（我想要删除橙色高亮显示的行），以及每个单独工作表的示例。 - Dan M

问题与您的复制方式有关。您选择工作表中的所有内容并一次性复制。Robin Mackenzie的代码将删除第一行，但在您的示例中这是不够的。个人建议循环遍历所有行，并检查单元格A、行中的值是否为数字。如果是数字，则复制，否则下一行。但是，这可能会消耗大量的CPU使用率。因此，您需要以不同的方式定义范围，使用我所描述的循环机制。 - Luuklag

使用循环机制的问题在于CPU使用率。这个电子表格将在整个公司范围内使用，每个工作表都有数百甚至数千个条目。是否可以通过实现第二个工作簿来解决这个问题，例如仅调用列A中具有数字值的行？ - Dan M

@DanM，我为此添加了一种使用Intersect和Offset的单行方法。由于这些函数依赖于Excel的内部模型，因此通常非常快速。 - Byron Wall

Answer 1

我还没有测试过，但是以下的内容应该可以帮助你，它会循环遍历单元格中的所有行，并使用union函数将其制作成一个新的范围。当检查完所有行的数值后，totalrange可以使用你的代码进行复制。

Dim row as integer
Dim temprange as range
Dim totalrange as range
Dim startrow as integer
For row = 2 to lastrow+1  `assuming there is always a title in row 1
If IsNum(Cells(row,1)) = false Then
    If temprange = Nothing then
         Set temprange = Range(Cells(2,1),Cells(row-1,[lastcolumn number] `[replace with number of last column]
         startrow = row+1
    Else
         Set temprange = Range(Cells(startrow,1),Cells(row-1,[lastcolumn number])
    End if
    If totalrange <> Nothing then
          Set totalrange = Union(totalrange,temprange)
    Else
          Set totalrange = temprange
    End if
End if
Next row

第二种方法：在复制之前删除标题行

For row = lastrow to 1 step -1
If IsNum(Cells(row,1) = False then
    Rows(row).EntireRow.Delete
End if
Next row

然后再次调用你的最后一行函数，并继续你的其他代码。

- Luuklag

---

刚想到，另一种方法是检查数字行，并删除那些不是数字的行。假设您不需要保留这些行。 - Luuklag

谢谢你提供的想法。第一个答案有效，但正如你所说，会严重占用 CPU。 我想尝试你提供的第二个方法，但我不明白在我的代码中应该放置它在哪里？ - Dan M

我认为最好的位置应该是在CopyRng.Copy之前。 - Luuklag

第一个示例缺少一些“Sets”。虽然这不是可执行代码，但如果有人复制/粘贴它（因为Excel VBA搜索者往往会这样做），那么某些可怜的灵魂将会遇到问题。此外，如果您使用Intersect和Offset，则可以通过一行代码来排除标题。请参见我的答案。 - Byron Wall

@ByronWall 包含了它们。 - Luuklag

Answer 2

如果您已经有一个现有的Range，并且只想要没有标题行的相同Range，可以使用简单的Intersect-Offset：

Set CopyRng = Intersect(CopyRng, CopyRng.Offset(1))

这只是将您给定的Range向下移动一行，然后仅保留与原始Range相交的部分。

使用这个新的Range，您可以安全地进行CopyRng.Copy操作，它将排除标题行。

- Byron Wall

---

Byron，确实是一个简单的解决方案。然而，OP的代码显示他一次性复制整个工作表，并且该工作表包含几个标题行，这些行之间的距离不可预测。那么循环遍历所有内容将是我能想到的唯一解决方案。 - Luuklag

@Luuklag，根据第一张图片，我认为那不正确。多个标题是每个工作表都复制了一个单独的标题的结果。您可以看到第二张图片是基于代码的输出表（粘贴目标）。上述方法将防止复制标题，因此输出保持干净。该代码需要一个标志来表示第一个工作表，但除此之外，单行Offset-Intersect是排除标题的标准方法。 - Byron Wall

啊，我现在明白了，我把这两个截图搞混了。那么你的方法，就像Robin的方法一样，确实更适合。 - Luuklag

Answer 3

如果您有一行作为标题行，您可以使用以下函数。如果您有多行，请增加lngTitleRows参数：

Option Explicit

Sub Test()

    UsedRangeLessFirstRow(Sheet1, 1).Select

End Sub

Function UsedRangeLessFirstRow(ws As Worksheet, lngTitleRows As Long) As Range

    Dim rngData As Range
    Dim lngDataRows As Long
    Dim lngDataColumns As Long

    Set rngData = ws.UsedRange
    lngDataRows = rngData.Rows.Count - lngTitleRows
    lngDataColumns = rngData.Columns.Count
    Set rngData = rngData.Offset(1, 0).Resize(lngDataRows, lngDataColumns)

    Set UsedRangeLessFirstRow = rngData

End Function

然后，不是使用以下内容：

Set CopyRng = sh.UsedRange

使用：

Set CopyRng = UsedRangeLessFirstRow(sh, 1)

- Robin Mackenzie

---

谢谢您的回答，但是对我来说似乎并没有起作用。我认为这是@Luuklag所说的原因：“您选择工作表中的所有内容并一次性复制全部内容。Robin Mackenzie的代码将删除第一行，但在您的示例中这是不够的。” - Dan M

请再次检查代码。它会删除每个工作表使用范围的标题行，这些使用范围将被复制。按照我在答案底部提到的方式在循环内部调用该函数。希望对你有帮助。 - Robin Mackenzie