从VBA中排除1行复制范围

Question

我正在编写一些代码来将多个工作表（它们构成各个零件清单）合并为一个大型零件清单。

到目前为止，我有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 

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

感谢所有帮助 丹

Answer 1

没有测试过，但这些方针的东西应该帮助你循环遍历单元格中的所有行，并使用联合函数创建一个新的范围。然后，当检查所有行的数值时，可以使用您的代码复制总范围。

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

如果你有1行，你可以使用下面的函数标题行。如果您有更多的再增加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，它会排除标题行。