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

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

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个小时，试图让它工作，但无济于事。 有任何想法吗？

Answer 1

这应该做你想要的快一点：

 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