excel - 将所有数据复制到一张纸上，问题循环 VBA

Question

您好，我正在尝试使用每张纸的最后一行复制一组列。我得到了这个代码，但它只适用于一张纸，而不是所有的纸。我不知道如何让它遍历所有工作表。

我试过使用 vba 代码

Option Explicit
Public Sub CombineDataFromAllSheets()

    Dim wksSrc As Worksheet, wksDst As Worksheet
    Dim rngSrc As Range, rngDst As Range
    Dim lngLastCol As Long, lngSrcLastRow As Long, lngDstLastRow As Long

    'Notes: "Src" is short for "Source", "Dst" is short for "Destination"

    'Set references Pup-front
    Set wksDst = ThisWorkbook.Worksheets("Import")
    lngDstLastRow = LastOccupiedRowNum(wksDst) '<~ defined below (and in Toolbelt)!
    lngLastCol = LastOccupiedColNum(wksDst) '<~ defined below (and in Toolbelt)!

    'Set the initial destination range
    Set rngDst = wksDst.Cells(2, 1)

    'Loop through all sheets
    For Each wksSrc In ThisWorkbook.Worksheets

        'Make sure we skip the "Import" destination sheet!
        If wksSrc.Name <> "Import" Then

            'Identify the last occupied row on this sheet
            lngSrcLastRow = LastOccupiedRowNum(wksSrc)

            'Store the source data then copy it to the destination range
            With wksSrc
                Set rngSrc = .Range(.Cells(2, 1), .Cells(lngSrcLastRow, 9))
                rngSrc.Copy Destination:=rngDst
            End With

            'Redefine the destination range now that new data has been added
            lngDstLastRow = LastOccupiedRowNum(wksDst)
            Set rngDst = wksDst.Cells(2, 1)

        End If

    Next wksSrc

End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT       : Sheet, the worksheet we'll search to find the last row
'OUTPUT      : Long, the last occupied row
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
    Dim lng As Long
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        With Sheet
            lng = .Cells.Find(What:="*", _
                              After:=.Range("A1"), _
                              Lookat:=xlPart, _
                              LookIn:=xlFormulas, _
                              SearchOrder:=xlByRows, _
                              SearchDirection:=xlPrevious, _
                              MatchCase:=False).Row
        End With
    Else
        lng = 1
    End If
    LastOccupiedRowNum = lng
End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT       : Sheet, the worksheet we'll search to find the last column
'OUTPUT      : Long, the last occupied column
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedColNum(Sheet As Worksheet) As Long
    Dim lng As Long
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        With Sheet
            lng = .Cells.Find(What:="*", _
                              After:=.Range("A1"), _
                              Lookat:=xlPart, _
                              LookIn:=xlFormulas, _
                              SearchOrder:=xlByColumns, _
                              SearchDirection:=xlPrevious, _
                              MatchCase:=False).Column
        End With
    Else
        lng = 1
    End If
    LastOccupiedColNum = lng
End Function

此代码仅在工作簿中执行一张工作表，而不是所有工作表

标签： excelvbacopy

Answer 1

在下面的代码中，我试图坚持您的命名约定，但以稍微不同的方式解决了这个要求。

源工作表名称被加载到 Variant wksSrcNames。然后我使用For Each循环从每个源工作表中复制数据。我相信这是从选定工作表中加载数据的最简单方法。

如果我正确解释了您的代码，您不会将源工作表的标题行复制到目标工作表。您只需将第 2 行从源工作表复制到 LastRow。我也这样做，但在复制任何数据行之前，我从第一个源工作表中复制标题行。

我计划像您一样复制包括公式在内的数据。在例程结束时，我会：

  ' Copy data in wksDst over itself to convert formulae to values
  With wksDst
    Set rngDst = .Range(.Cells(1, 1), .Cells(lngDstNextRow - 1, lngLastCol)
  End With
  rngDst.Value = rngDst.Value

将整个工作表“导入”复制到自身，将所有公式转换为值。这种技术可能对你有用，但它不适用于我的测试数据，因为我Row()在一些公式中包含了这个函数。当我将源工作表中的一行复制到“导入”时，该值更改为反映工作表“导入”中的行号。当我将公式转换为值时，我冻结了新值而不是原始值。

我现在分两个阶段复制数据。第一阶段和你的一样。这会移动任何单元格级别的格式。然后我将源值复制到 Variant，然后将 Variant 复制到目标范围。这会将公式转换为其原始值。

我认为您会发现此代码不言自明，但如有必要，请提出问题：

Option Explicit

  ' You use literal 9 in your code for the number of columns.
  ' In six months or a year someone will add or remove a column.
  ' You will then have to search through your code for those 9s
  ' which identify the last column. You may be lucky and that
  ' is the only use of 9. If you had ever had to check code for
  ' a literal that was no longer correct, you would understand
  ' why I never use them. With a constant, change the constant
  ' and the code is fixed.

  ' Your code assumes one header row which is not copied to
  ' worksheet "Import".

  Const lngLastCol As Long = 9
  Const lngFirstDataRow As Long = 2
Public Sub CombineDataFromAllSheets()

  Dim wksSrc As Worksheet, wksDst As Worksheet
  Dim rngSrc As Range, rngDst As Range
  Dim lngSrcLastRow As Long, lngDstNextRow As Long
  Dim wksSrcNames As Variant, wksSrcName As Variant
  Dim CellValues As Variant

  'Notes: "Src" is short for "Source", "Dst" is short for "Destination"

  ' ThisWorkBook is the workbook containing the macro.  If you have
  ' multiple workbooks open, you have to be really careful to identify
  ' the correct workbook.  Sometimes you identify the workbook and
  ' sometimes you don't.  I have removed ThisWorkbook when you used it.

  'Set references Pup-front
  Set wksDst = Worksheets("Import")

  ' VBA.Array will set wksSrcNames to a zero-based array of worksheet
  ' names. To add another worksheet or change the sequence, just update
  ' this statement.
  wksSrcNames = VBA.Array("Pro Rates", "Weekly Labor")

  With wksDst
    ' Clear any previous data
    .Cells.EntireRow.Delete
  End With

  ' Copy the header rows , if any, from the first worksheet.
  ' I assume you have no formulae in your header row.
  If lngFirstDataRow > 1 Then
    Set wksSrc = Worksheets(wksSrcNames(0))
    With wksSrc
      Set rngSrc = .Range(.Cells(1, 1), .Cells(lngFirstDataRow - 1, lngLastCol))
    End With
    lngDstNextRow = 1
    rngSrc.Copy Destination:=wksDst.Cells(lngDstNextRow, 1)
  End If

  ' Prepare lngDstNextRow for first set of data rows
  lngDstNextRow = lngFirstDataRow

   For Each wksSrcName In wksSrcNames

    Set wksSrc = Worksheets(wksSrcName)
    lngSrcLastRow = LastOccupiedRowNum(wksSrc)
    With wksSrc
      Set rngSrc = .Range(.Cells(lngFirstDataRow, 1), .Cells(lngSrcLastRow, lngLastCol))
    End With
    With wksDst
      Set rngDst = .Range(.Cells(lngDstNextRow, 1), _
                          .Cells(lngDstNextRow + rngSrc.Rows.Count - 1, lngLastCol))
    End With
    ' Copy values, formulae and formats
    rngSrc.Copy Destination:=wksDst.Cells(lngDstNextRow, 1)
    ' Copy values
    CellValues = rngSrc.Value
    rngDst.Value = CellValues
    ' Prepare lngDstNextRow for next set of data rows
    lngDstNextRow = lngDstNextRow + rngSrc.Rows.Count

  Next

  With wksDst
    .Columns.AutoFit  ' Set column widths so data fits
  End With

End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT       : Sheet, the worksheet we'll search to find the last row
'OUTPUT      : Long, the last occupied row
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
    Dim lng As Long
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        With Sheet
            lng = .Cells.Find(What:="*", _
                              After:=.Range("A1"), _
                              Lookat:=xlPart, _
                              LookIn:=xlFormulas, _
                              SearchOrder:=xlByRows, _
                              SearchDirection:=xlPrevious, _
                              MatchCase:=False).Row
        End With
    Else
        lng = 1
    End If
    LastOccupiedRowNum = lng
End Function