从VBA复制范围中排除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 

然后我有另一个创build一个名为“部件列表”的工作表，并粘贴在那里的范围。

 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 

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

感谢任何帮助丹

Answer 1

还没有testing过，但沿着这些线路的东西应该通过循环遍历单元格中的所有行，并使用联合函数创build一个新的范围。 然后，当检查所有行的数值时，可以使用您的代码复制总量。

 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 

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

Answer 2

如果您有一行作为标题行，则可以使用以下function。 如果你有更多的话，增加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) 

Answer 3

如果你有一个现有的Range ，你只需要没有标题行相同的Range ，做一个简单的Intersect-Offset ：

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

这只需要你给定的Range ，将其向下移动一行，然后只保留与原始Range相交的部分。

有了这个新的Range ，你可以安全地做你的CopyRng.Copy ，它将排除标题行。