VBA，从多工作表复制行到主工作表

我有一个macros为工作簿中的所有工作表进行计算，我需要将这些结果（位于每个工作表的最后一行，但每个工作表的每行可能不同）复制到工作表中（因为它需要为多个文件完成），任何人都可以帮助改变我的macros做这个，甚至做一个新的？

如果需要这里是我的macros：

Sub Calculationallsheetsv2() 'Calculation all sheets, even when there is only headers Dim xrng As Range, lrw As Long, lrng As Range, i As Long Dim LstCo As Long, ws As Worksheet With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With For Each ws In ActiveWorkbook.Worksheets With ws If Not Application.WorksheetFunction.CountA(.Cells) = 0 Then LstCo = .Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column For i = 1 To LstCo With .Columns(i) .TextToColumns Destination:=.Cells(1, 1), DataType:=xlDelimited, TrailingMinusNumbers:=True End With Next lrw = .Columns("A:Y").Find("*", , xlValues, , xlRows, xlPrevious).row If lrw = 1 Then lrw = 2 Set lrng = .Range("A" & lrw + 2) With .Range("A2:A" & lrw) lrng.Formula = "=COUNTA(" & .Address(0, 0) & ")/ROWS(" & .Address(0, 0) & ")" End With Set xrng = .Range(lrng, .Cells(lrng.row, LstCo)) lrng.AutoFill xrng, Type:=xlFillDefault xrng.Style = "Percent" End If End With Next With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic Application.CalculateFull End With End Sub 

Answer 1

以下是完成您所描述的任务的代码。 我发表了一些评论，所以你可以理解发生了什么事情。 如果您有关于此代码的任何其他问题，请发表评论。

注意 。 在下面的代码中使用了一个外部函数，因此您需要将其包含在代码中，否则将无法编译。 这里是这个函数的代码 – 函数来查找给定的工作表中的最后一个非空行 。

 Sub Calculationallsheetsv2() 'Calculation all sheets, even when there is only headers Const SUMMARY_SHEET_NAME As String = "Summary" '----------------------------------------- Dim wkb As Excel.Workbook Dim wks As Excel.Worksheet Dim wksSummary As Excel.Worksheet Dim arrRow As Variant Dim lastRow As Long '----------------------------------------- With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Set wkb = Excel.ActiveWorkbook 'Create [Summary] worksheet. ----------------------------------------------------- On Error Resume Next Set wksSummary = wkb.Worksheets(SUMMARY_SHEET_NAME) On Error GoTo 0 If wksSummary Is Nothing Then Set wksSummary = wkb.Worksheets.Add wksSummary.Name = SUMMARY_SHEET_NAME End If '--------------------------------------------------------------------------------- 'Iterate through all the worksheets in the workbook [wkb]. For Each wks In wkb.Worksheets 'Check the name of currently checked worksheet to exclude [Summary] worksheet 'from this process. If wks.Name <> SUMMARY_SHEET_NAME Then 'Check if there are any non-empty cells in this worksheet. If Application.WorksheetFunction.CountA(wks.Cells) Then 'Find the index number of the last empty row. lastRow = lastNonEmptyRow(wks) 'Copy the content of this row into array. arrRow = wks.Rows(lastRow).EntireRow 'Paste the content of [arrRow] array into the first empty 'row of the [Summary] worksheet. With wksSummary .Rows(lastNonEmptyRow(wksSummary) + 1).EntireRow = arrRow End With End If End If Next wks 'Restore screen updating and automatic calculation With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic Call .CalculateFull End With End Sub 

---

编辑

如果要将结果放入新工作簿而不是新工作表中，则需要replace此代码块：

  'Create [Summary] worksheet. ----------------------------------------------------- On Error Resume Next Set wksSummary = wkb.Worksheets(SUMMARY_SHEET_NAME) On Error GoTo 0 If wksSummary Is Nothing Then Set wksSummary = wkb.Worksheets.Add wksSummary.Name = SUMMARY_SHEET_NAME End If '--------------------------------------------------------------------------------- 

与这一个：

  'Create [Summary] worksheet. ----------------------------------------------------- Dim wkbSummary As Excel.Workbook Set wkbSummary = Excel.Workbooks.Add Set wksSummary = wkbSummary.Worksheets.Add wksSummary.Name = SUMMARY_SHEET_NAME '---------------------------------------------------------------------------------