excel - 从VBA复制范围中排除1行

我正在编写一些代码来合并多个工作表，这些工作表将单个零件列表形成1个大零件列表。

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

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

然后，我还有另一个子创建了一个新的工作表，称为“零件列表”，并将范围粘贴到其中。

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

我遇到的问题是标题行正在与范围一起复制。有谁知道如何从行和列扫描或复制中排除标题？




谢谢你的帮助
担

最佳答案

尚未测试过，但是遵循这些原则的东西应该可以帮助您遍历单元格中的所有行，并使用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

然后再次调用您的最后一行函数，并执行其余代码。