Vba 从多张工作表复制到单独的工作簿

我需要编写一些代码来运行特定工作簿的每个工作表，并将特定单元格复制到单独的工作簿中。指定要复制到的目标工作表时遇到问题。到目前为止，我所拥有的：

Private Sub CommandButton1_Click()

Dim wb As Workbook, wbhold As Workbook
Dim ws As Worksheet, wshold As Worksheet
Dim holdCount As Integer
Dim cellColour As Long
Dim cell As Range, rng As Range


Set wb = Workbooks.Open("blahblah.xls")
Set wbhold = Workbooks.Open("blahblah2.xlsm")


holdCount = 0
cellColour = RGB(255, 153, 0)
rownumber = 0

For Each ws In wb.Worksheets
With ws
    Set rng = ws.Range("A1:A20")
    For Each cell In rng
        rownumber = rownumber + 1
        If cell.Interior.Color = cellColour Then
                Range("A" & rownumber & ":B" & rownumber).Select
                Selection.Copy
                wbhold.Activate
                Sheets("Hold Data").Activate
                Cells.Offset(1, 0).PasteSpecial
                Application.CutCopyMode = False
                With Selection.Font
                    .Name = "Arial"
                    .Size = 10
                    wb.Activate
                End With
                holdCount = holdCount + 1
        End If
    Next cell
End With
Next ws
Application.DisplayAlerts = False
wb.Close

MsgBox "found " & holdCount

End Sub

---

但行：

Sheets（“Hold Data”）.Activate

不断抛出“下标超出范围”错误。我已经花了大约2个小时的时间来处理代码，试图让它正常工作，但是没有用。有什么想法吗？

这应该能让你想做的更快一些：

Private Sub CommandButton1_Click()

    Dim wb As Workbook, wbhold As Workbook
    Dim ws As Worksheet, wshold As Worksheet
    Dim holdCount             As Integer
    Dim cellColour            As Long
    Dim cell As Range, rng    As Range
    Dim outrow                As Long

    Application.ScreenUpdating = False

    Set wb = Workbooks.Open("blahblah.xls")
    Set wbhold = Workbooks.Open("blahblah2.xlsm")
    Set wshold = wbhold.Worksheets("Hold Data")

    holdCount = 0
    cellColour = RGB(255, 153, 0)
    outrow = 1

    For Each ws In wb.Worksheets
        Set rng = Nothing
        With ws
            For Each cell In .Range("A1:A20")
                If cell.Interior.Color = cellColour Then
                    If rng Is Nothing Then
                        Set rng = cell.resize(, 2)
                    Else
                        Set rng = Union(rng, cell.Resize(, 2))
                    End If
                    holdCount = holdCount + 1
                End If
                If Not rng Is Nothing Then
                    rng.Copy wshold.Cells(outrow, "A")
                    outrow = outrow + rng.Cells.Count \ 2
                End If
            Next cell
        End With
    Next ws

    With wshold.Cells(1, "A").CurrentRegion.Font
        .Name = "Arial"
        .Size = 10
    End With

    wb.Close False

    Application.ScreenUpdating = True

    MsgBox "found " & holdCount

End Sub

---

您实际要粘贴到哪里-哪些单元格？它只需要开始粘贴到A1和B1中[这只是从每行复制两个单元格的数据]，然后在循环的每次迭代中向下移动一行。我在VBA方面完全是个新手[你可以告诉我]，所以它所花的时间可能比它应该花的时间要长。我在“Set wshold=wbhold.Worksheets（“Hold Data”）”中得到了一个“下标超出范围”错误，只是重复检查了一下，工作表名称匹配了。我在前面的代码中也遇到了这个错误，这就是为什么原始问题中的行被删除的原因。可能是您的工作簿错误，或者工作表名称错误。没有其他的可能性。我认为这是因为我试图将数据导入到带有命令按钮的工作表中。我已经将其更改为保存到一个单独的xlsx文件中，并且不再因此而出现错误。但是，现在它正在复制整个工作表，而不仅仅是指定的单元格，并同时给出一个错误：“您不能在这里粘贴，因为复制区域和粘贴区域的大小不一样”行：“rng.copy wshold.cells（outrow，“A”）”我刚刚更正了代码中的一个错误-您可以尝试新版本吗？