Excel VBA - 通过循环将数据从一个工作表复制到另一个工作表答案

【问题标题】：Excel VBA - Copy data from one worksheet to another via loopExcel VBA - 通过循环将数据从一个工作表复制到另一个工作表
【发布时间】：2017-12-14 01:17:45
【问题描述】：

这基本上是我能找到的关于该主题的所有其他主题的变体。

我有一个工作表（我们将在 wbk2 中说 sh1），其中 B2:D8 列中的值。我需要遍历单元格并将数据复制到 wbk1 的 sh1 中的 B2:D8。范围永远不会改变，但值会。而且，我想使用循环而不是简单的复制和粘贴。

接下来，我有一个范围相同的不同工作表（wbk3 中的 sh1）。我想循环并复制单元格值，但是这一次，我想增加已经存在的值，而不是粘贴到 wbk1。我想要结束的是 wbk 的 2 和 3 中特定单元格中的值的总和，粘贴到 wbk1 中的同一单元格中。

伪代码：

rng1 = wbk1.Range("B2:D8")
rng2 = wbk2.Range("B2:D8")
rng3 = wbk3.Range("B2:D8")
For Each value In rng2
Copy data to rng1
Next value
For Each value In rng3
Merge data to rng1
Next value

感谢任何入门提示。

编辑：

在下面使用 YowE3K 的帮助下，现在的代码是：

    Dim r As Long
    Dim c As Long
    For r = 2 To 8
        For c = 2 To 4
            combinedReports.Worksheets("combinedQualities").Cells(r, c).Value = snowq.Worksheets("qsum").Cells(r, c).Value + qual.Worksheets("qsum").Cells(r, c).Value
        Next
    Next

现在列出了正确的工作簿和工作表。在此代码之前，运行单独的代码为每个工作簿/工作表提供 B2:D8 范围内的数据。我现在唯一遇到的问题是，当代码运行到以“combinedReports.Worksheets”.......开头的行时，我得到一个 424 object required run-time 错误。我回来检查以确保所有变量都已声明，它们似乎是。鉴于此错误，这是否意味着我仍然在某处缺少声明？仅供参考，在此之前的所有其他操作都没有问题，因此可能只是这一行输入错误。

编辑：整个代码粘贴在下面，其中包括在失败行之前调用的 2 组代码...

Sub ReportCombiner()
'
' ReportCombiner Macro
'
'
'Create new workbook
    Dim combinedReports As Workbook, combinedCsats As Worksheet, combinedQualities As Worksheet, combinedTickets As Worksheet
    Set combinedReports = Workbooks.Add
    Sheets("Sheet1").name = "Combined CSAT's"
    Set combinedCsats = combinedReports.Sheets("Combined CSAT's")
    Sheets.Add After:=ActiveSheet
    Sheets("Sheet2").name = "Combined Qualities"
    Set combinedQualities = combinedReports.Sheets("Combined Qualities")
    Sheets.Add After:=ActiveSheet
    Sheets("Sheet3").name = "Combined Tickets"
    Set combinedTickets = combinedReports.Sheets("Combined Tickets")

'Change analysts to variables
    Set Anal = Workbooks.Open("D:\Users\stefan.bagnato\Desktop\Analysts\Analysts")
    Dim var1, var2, var3, var4, var5, var6, var7 As String
    var1 = Workbooks("Analysts").Worksheets("Analysts").Range("A1")
    var2 = Workbooks("Analysts").Worksheets("Analysts").Range("A2")
    var3 = Workbooks("Analysts").Worksheets("Analysts").Range("A3")
    var4 = Workbooks("Analysts").Worksheets("Analysts").Range("A4")
    var5 = Workbooks("Analysts").Worksheets("Analysts").Range("A5")
    var6 = Workbooks("Analysts").Worksheets("Analysts").Range("A6")
    var7 = Workbooks("Analysts").Worksheets("Analysts").Range("A7")
    Workbooks("Analysts").Close

'Qualities
    'Create quality table
        'Add table headers
            combinedQualities.Activate
            Range("A2") = var1
            Range("A3") = var2
            Range("A4") = var3
            Range("A5") = var4
            Range("A6") = var5
            Range("A7") = var6
            Range("A8") = var7
            Range("B1") = "Valid Qualities"
            Range("C1") = "Invalid Qualities"
            Range("D1") = "Total Qualities"
        'Justify cells
            Range("B2:D8").HorizontalAlignment = xlCenter
        'Format cells
            Range("A2:A8,B1:D1").Font.Bold = True
            Range("B1:D1").Font.Size = 12
        'Widen columns
            Range("A:A").ColumnWidth = 18
            Range("B:D").ColumnWidth = 16
    'Run SNOW Quality report
        Call ServiceNowQualityReport
    'Run CA Quality report
        Call CAQualityReport
    'Add data to combo table
        Dim r As Long
        Dim c As Long
        For r = 2 To 8
            For c = 2 To 4
                combinedReports.Worksheets("combinedQualities").Cells(r, c).Value = snowq.Worksheets("qsum").Cells(r, c).Value + qual.Worksheets("qsum").Cells(r, c).Value
            Next
        Next

End Sub



Sub ServiceNowQualityReport()
'
' ServiceNow Quality Report Macro
'
'
'Create new workbook
    Dim snowq As Workbook, snowqws As Worksheet
    Set snowq = Workbooks.Add
    Sheets("Sheet1").name = "Qualities"
    Set snowqws = snowq.Sheets("Qualities")

'Combine reports
    'Qualitied Incidents
        Set incq = Workbooks.Open("D:\Users\stefan.bagnato\Desktop\Latest Reports\snowincqual")
        Sheets("Page 1").name = "Qualitied Incidents"
        Set incqws = incq.Sheets("Qualitied Incidents")
        lastRowIncqws = incqws.Range("A" & Rows.Count).End(xlUp).Row
        lastRowSnowqws = snowqws.Range("A" & Rows.Count).End(xlUp).Row
        incqws.Range("A2:J" & lastRowIncqws).Copy snowqws.Range("A" & lastRowSnowqws)
        Workbooks("snowincqual").Close savechanges:=False
    'Qualitied RITM's
        Set ritmq = Workbooks.Open("D:\Users\stefan.bagnato\Desktop\Latest Reports\snowritmqual")
        Sheets("Page 1").name = "Qualitied RITM's"
        Set ritmqws = ritmq.Sheets("Qualitied RITM's")
        lastRowRitmqws = ritmqws.Range("A" & Rows.Count).End(xlUp).Row
        lastRowSnowqws = snowqws.Range("A" & Rows.Count).End(xlUp).Row + 1
        ritmqws.Range("A2:J" & lastRowRitmqws).Copy snowqws.Range("A" & lastRowSnowqws)
        Workbooks("snowritmqual").Close savechanges:=False
        Application.CutCopyMode = False

'Format table
    'Add headers
        Range("A1") = "Ticket Number"
        Range("B1") = "Opened Date"
        Range("C1") = "Created By"
        Range("D1") = "Short Description"
        Range("E1") = "Quality Submitted Date"
        Range("F1") = "Quality By"
        Range("G1") = "Quality Reason"
        Range("H1") = "Quality Comments"
        Range("I1") = "Quality Resolved By"
        Range("J1") = "Quality Resolution Comments"
    'Widen columns and rows
        Columns("A:A").ColumnWidth = 15
        Columns("B:B").ColumnWidth = 18
        Range("C:C,I:I").ColumnWidth = 20
        Columns("D:D").ColumnWidth = 30
        Columns("E:G").ColumnWidth = 24
        Range("H:H,J:J").ColumnWidth = 40
        Rows("1:1").RowHeight = 20
        lastRow = Cells(Rows.Count, "A").End(xlUp).Row
        Range("A1:A" & lastRow).RowHeight = 18
    'Justify cells
        Range("A1:J" & lastRow).HorizontalAlignment = xlLeft
    'Format cells
        Range("B2:B" & lastRow, "E2:E" & lastRow).NumberFormat = "mm/dd/yyyy hh:mm:ss"
        Range("A1:J1").Font.Bold = True
        Range("A1:J1").Font.Size = 12
    'Wrap text
        Range("A1:J" & lastRow).WrapText = True
    'AutoFit columns
        Range("D:D,H:H,J:J").Rows.AutoFit

'Sort by Quality Submitted Date
    Worksheets("Qualities").Sort.SortFields.Add Key:=Range("E1"), SortOn:=xlSortOnValues, Order:=xlAscending
    With Worksheets("Qualities").Sort
        .SetRange Range("A2:J" & lastRow)
        .Orientation = xlTopToBottom
        .Apply
    End With

'Add new worksheet
    Sheets.Add
    Sheets("Sheet2").name = "Summed Data"

'Change analysts to variables
    Set Anal = Workbooks.Open("D:\Users\stefan.bagnato\Desktop\Analysts\Analysts")
    Dim var1, var2, var3, var4, var5, var6, var7 As String
    var1 = Workbooks("Analysts").Worksheets("Analysts").Range("A1")
    var2 = Workbooks("Analysts").Worksheets("Analysts").Range("A2")
    var3 = Workbooks("Analysts").Worksheets("Analysts").Range("A3")
    var4 = Workbooks("Analysts").Worksheets("Analysts").Range("A4")
    var5 = Workbooks("Analysts").Worksheets("Analysts").Range("A5")
    var6 = Workbooks("Analysts").Worksheets("Analysts").Range("A6")
    var7 = Workbooks("Analysts").Worksheets("Analysts").Range("A7")
    Workbooks("Analysts").Close

'Format table
    'Add table headers
        Range("A2") = var1
        Range("A3") = var2
        Range("A4") = var3
        Range("A5") = var4
        Range("A6") = var5
        Range("A7") = var6
        Range("A8") = var7
        Range("B1") = "Valid Qualities"
        Range("C1") = "Invalid Qualities"
        Range("D1") = "Total Qualities"
    'Justify cells
        Range("B2:D8").HorizontalAlignment = xlCenter
    'Format cells
        Range("A2:A8,B1:D1").Font.Bold = True
        Range("B1:D1").Font.Size = 12
    'Widen columns
        Range("A:A").ColumnWidth = 18
        Range("B:D").ColumnWidth = 16

'Fill in data
    Dim qual As Worksheet, qsum As Worksheet, qRange As Range
    Set qual = Sheets("Qualities")
    Set qsum = Sheets("Summed Data")
    Set qRange = qual.Range("J2:J" & lastRow)
    'Qualities
        qsum.Range("B2") = WorksheetFunction.CountIfs(qRange, "Valid on Kris" & Search & "*")
        qsum.Range("B3") = WorksheetFunction.CountIfs(qRange, "Valid on Matt" & Search & "*")
        qsum.Range("B4") = WorksheetFunction.CountIfs(qRange, "Valid on Shawn" & Search & "*")
        qsum.Range("B5") = WorksheetFunction.CountIfs(qRange, "Valid on Stefan" & Search & "*")
        qsum.Range("B6") = WorksheetFunction.CountIfs(qRange, "Valid on Trey" & Search & "*")
        qsum.Range("B7") = WorksheetFunction.CountIfs(qRange, "Valid on Tyler" & Search & "*")
        qsum.Range("B8") = WorksheetFunction.CountIfs(qRange, "Valid on Whitney" & Search & "*")
        qsum.Range("C2") = WorksheetFunction.CountIfs(qRange, "Feedback NA for Kris" & Search & "*")
        qsum.Range("C3") = WorksheetFunction.CountIfs(qRange, "Feedback NA for Matt" & Search & "*")
        qsum.Range("C4") = WorksheetFunction.CountIfs(qRange, "Feedback NA for Shawn" & Search & "*")
        qsum.Range("C5") = WorksheetFunction.CountIfs(qRange, "Feedback NA for Stefan" & Search & "*")
        qsum.Range("C6") = WorksheetFunction.CountIfs(qRange, "Feedback NA for Trey" & Search & "*")
        qsum.Range("C7") = WorksheetFunction.CountIfs(qRange, "Feedback NA for Tyler" & Search & "*")
        qsum.Range("C8") = WorksheetFunction.CountIfs(qRange, "Feedback NA for Whitney" & Search & "*")
    'Sums
        Range("D2") = "=SUM(RC[-2]:RC[-1])"
        Range("D3") = "=SUM(RC[-2]:RC[-1])"
        Range("D4") = "=SUM(RC[-2]:RC[-1])"
        Range("D5") = "=SUM(RC[-2]:RC[-1])"
        Range("D6") = "=SUM(RC[-2]:RC[-1])"
        Range("D7") = "=SUM(RC[-2]:RC[-1])"
        Range("D8") = "=SUM(RC[-2]:RC[-1])"

    Application.CutCopyMode = False
End Sub


Sub CAQualityReport()
'
' CA Quality Report Macro
'
'
'Initialize workbook
    Dim CAQual As Workbook
    Set CAQual = Workbooks.Open("D:\Users\stefan.bagnato\Desktop\Latest Reports\qual")
    Sheets("RAW").name = "Qualities"

'Remove the extra column and rows
    Rows("1:3").Delete Shift:=xlUp
    Range("A:A,E:G,L:Q,U:U,W:W").Delete Shift:=xlToLeft

'Change analysts to variables
    Set Anal = Workbooks.Open("D:\Users\stefan.bagnato\Desktop\Analysts\Analysts")
    Workbooks("qual.xlsx").Activate
    Dim var1, var2, var3, var4, var5, var6, var7 As String
    var1 = Workbooks("Analysts").Worksheets("Analysts").Range("A1")
    var2 = Workbooks("Analysts").Worksheets("Analysts").Range("A2")
    var3 = Workbooks("Analysts").Worksheets("Analysts").Range("A3")
    var4 = Workbooks("Analysts").Worksheets("Analysts").Range("A4")
    var5 = Workbooks("Analysts").Worksheets("Analysts").Range("A5")
    var6 = Workbooks("Analysts").Worksheets("Analysts").Range("A6")
    var7 = Workbooks("Analysts").Worksheets("Analysts").Range("A7")
    Workbooks("Analysts").Close

'Remove all analysts not wanted in the table
    Dim Names As String, r As Range
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Names = "Dana IT Service Catalog,Kristopher Snyder,Matthew Williams,Shawn Dwyer,Trey Skandier,Tyler Brown,Stefan Bagnato,Whitney Royal"
    ary = Split(Names, ",")
    Set r = Range("A1:X" & lastRow)
    With r
        .AutoFilter Field:=4, Criteria1:=(ary), Operator:=xlFilterValues
    End With

'Add a new worksheet
    Sheets.Add
    Sheets("Sheet1").name = "Summed Qualities"

'Format table
    'Add table headers on the new sheet
        Range("A2") = var1
        Range("A3") = var2
        Range("A4") = var3
        Range("A5") = var4
        Range("A6") = var5
        Range("A7") = var6
        Range("A8") = var7
        Range("B1") = "Valid Qualities"
        Range("C1") = "Invalid Qualities"
        Range("D1") = "Total Qualities"
    'Format the table
        Range("A2:A8,B1:D1").Font.Bold = True
        Range("A:A").ColumnWidth = 18
        Range("B:D").ColumnWidth = 15

'Fill in data
    Dim q As Worksheet, qsum As Worksheet, qual As Range
    Set q = Sheets("Qualities")
    Set qsum = Sheets("Summed Qualities")
    Set qual = Sheets("Qualities").Range("K1:K" & lastRow)

'Find the values
    qsum.Range("B2") = WorksheetFunction.CountIfs(qual, "Valid on Kris" & Search & "*")
    qsum.Range("B3") = WorksheetFunction.CountIfs(qual, "Valid on Matt" & Search & "*")
    qsum.Range("B4") = WorksheetFunction.CountIfs(qual, "Valid on Shawn" & Search & "*")
    qsum.Range("B5") = WorksheetFunction.CountIfs(qual, "Valid on Stefan" & Search & "*")
    qsum.Range("B6") = WorksheetFunction.CountIfs(qual, "Valid on Trey" & Search & "*")
    qsum.Range("B7") = WorksheetFunction.CountIfs(qual, "Valid on Tyler" & Search & "*")
    qsum.Range("B8") = WorksheetFunction.CountIfs(qual, "Valid on Whitney" & Search & "*")

    qsum.Range("C2") = WorksheetFunction.CountIfs(qual, "Feedback NA for Kris" & Search & "*")
    qsum.Range("C3") = WorksheetFunction.CountIfs(qual, "Feedback NA for Matt" & Search & "*")
    qsum.Range("C4") = WorksheetFunction.CountIfs(qual, "Feedback NA for Shawn" & Search & "*")
    qsum.Range("C5") = WorksheetFunction.CountIfs(qual, "Feedback NA for Stefan" & Search & "*")
    qsum.Range("C6") = WorksheetFunction.CountIfs(qual, "Feedback NA for Trey" & Search & "*")
    qsum.Range("C7") = WorksheetFunction.CountIfs(qual, "Feedback NA for Tyler" & Search & "*")
    qsum.Range("C8") = WorksheetFunction.CountIfs(qual, "Feedback NA for Whitney" & Search & "*")

'Sum values
    Range("D2") = "=SUM(RC[-2]:RC[-1])"
    Range("D3") = "=SUM(RC[-2]:RC[-1])"
    Range("D4") = "=SUM(RC[-2]:RC[-1])"
    Range("D5") = "=SUM(RC[-2]:RC[-1])"
    Range("D6") = "=SUM(RC[-2]:RC[-1])"
    Range("D7") = "=SUM(RC[-2]:RC[-1])"
    Range("D8") = "=SUM(RC[-2]:RC[-1])"

    Application.CutCopyMode = False
End Sub

【问题讨论】：

看看stackoverflow.com/questions/12527725/…
确保您的伪语法已指定工作表。如果 sh1 是 wbk3 中的工作表，则 wbk3 是工作簿，您不能拥有 workbook.range 例如wbk3.Range("B2:D8")
所以你想将 wbk1 的内容归零，然后循环遍历其他工作簿（wbk2、wbk3，可能是 wbk4 等），将值添加到 wbk1 中的任何内容。那么问题是您不知道如何将值归零吗？或者如何遍历工作簿？或者如何遍历行/列？或者如何访问单元格中的值？或者如何添加两个数字？或者如何将数字写入单元格？
@QHarr，我的错，我放错了字符。我的意思是表示工作表
@YowE3K，我只需要将工作表 2 和 3 中的范围组合起来并将它们添加到 1。我相信这个问题很清楚；我只是需要一些帮助来正确编写循环，因为我无法这样做。

标签： vba excel

【解决方案1】：

基于您唯一的问题是执行循环的 cmets，那么以下代码应该可以实现您想要的。（请注意，此代码使用您在“伪代码”中提到的wbk1 等，就好像它们是对相关工作表的引用一样。）

Dim r As Long
Dim c As Long
For r = 2 To 8
    For c = 2 To 4
        wbk1.Cells(r, c).Value = wbk2.Cells(r, c).Value + wbk3.Cells(r, c).Value
    Next
Next

如果您将当前代码（除了循环之外的所有内容）粘贴到问题中，则可以根据您的具体情况更好地定制。

【讨论】：