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

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