copy from multiple sheets to seperate workbook - vba

Question

I need to write some code to run through each worksheet of a specific workbook, and copy specific cells to a separate workbook. I'm having trouble specifying the destination worksheet to copy to. What I have so far:
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
But the line: Sheets("Hold Data").Activate keeps throwing up a "Subscript out of range" error. I've been playing around with the code for about 2 hours now, trying to get it to work, but to no avail. Any ideas?

Answer 1

This should do what you want a little faster:
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