Question

我是VBA的新手，没有注意到它可以在简单的宏上工作以自动化我的时间。

我正在寻找一个Excel宏，它在同一模板的一系列工作表的不同区域上复制特定的单元格（参见图像，我想复制黄色，灰色和绿色单元格）。所有工作表都在同一工作簿上工作。主要任务是：将所有这些作为值，依次放在一张纸上，使用相同的标题，并在此列的末尾添加总和。如果保持/使用模板并在那里总结值更简单，那么对我来说也没关系。如果我创建了20张新工作表，则宏将读取已存在的工作表和新工作表，并将其合并到“合并”工作表中。

我找到的代码几乎可以完成我需要的所有内容，但我正在努力改变de range以复制我想要的区域。

就像我说的那样，使用模板（从主模板创建一个副本并在那里汇总值？）或者简单地将值并排组合，所以每行代表一张表，对我来说也好。

请提前感谢，欢迎任何帮助。

我使用的代码如下 [source]。

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 sheet "Consolidado" if it exist
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("Consolidado").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    'Add a worksheet with the name "Consolidado"
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "Consolidado"

    'loop through all worksheets and copy the data to the DestSh
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> DestSh.Name And sh.Name <> "Menu" And sh.Name <> "Infos" And sh.Name <> "Log Update" And sh.Name <> "Master" Then

            'Find the last row with data on the DestSh
            Last = LastRow(DestSh)


            'Fill in the range that you want to copy
            Set CopyRng = sh.Range("A1").CurrentRegion



            'Test if there enough rows in the DestSh to copy all the data
            If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                MsgBox "There are not enough rows in the Destsh"
                GoTo ExitTheSub
            End If

            'This example copies values/formats, if you only want to copy the
            'values or want to copy everything look at the example below this macro
            CopyRng.Copy
            With DestSh.Cells(Last + 1, "A")
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With
        End If
    Next

ExitTheSub:

    Application.Goto DestSh.Cells(1)

    'AutoFit the column width in the DestSh sheet
    DestSh.Columns.AutoFit

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

The Excel Template

修改：

结果可以是下面两个中的一个，这更容易做到。

Result sheet option 1

Result sheet option 2

编辑2

Clean workbook

Answer 1

在评论中澄清后，我会做如下：

为简单起见，我们采取以下模板：

因此，您希望工作表A2中的单元格Consolidado为所有其他工作表的单元格A2的总和，以及其他单元格的总和。

我建议如下：您从模板创建工作表Consolidado。然后，在valueCells数组中填入要在Consolidado表格中总结的单元格列表。

然后，下面的代码将遍历目标工作表，并将数组中每个单元格的值添加到outputArray。总结目标表后，将其粘贴到Consolidado表 Sub CopyRangeFromMultiWorksheets（）

    Dim wb As Workbook
    Dim sh As Worksheet
    Dim DestSh As Worksheet

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set wb = ThisWorkbook
    Set DestSh = wb.Sheets("Consolidado")

    valueCells = Array("A2", "C2", "A4", "B4", "C4")

    Dim outputArray As Double
    ReDim outputArray(UBound(valueCells))

    For Each sh In wb.Worksheets
        If sh.Name <> DestSh.Name And sh.Name <> "Menu" And sh.Name <> "Infos" And sh.Name <> "Log Update" And sh.Name <> "Master" Then
            For i = LBound(valueCells) To UBound(valueCells)
                outputArray(i) = outputArray(i) + sh.Range(valueCells(i))
            Next i
        End If
    Next sh

    For i = LBound(valueCells) To UBound(valueCells)
        DestSh.Range(valueCells(i)) = outputArray(i)
    Next i




End Sub

在标准模板上复制特定范围/单元格

1 个答案: