從多個工作表複製到單獨的工作簿

Question

我需要編寫一些代碼以運行特定工作簿的每個工作表，並將特定單元複製到單獨的工作簿。我無法指定要複製到的目標工作表。我有什麼至今：

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