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不断提出一个＆＃34;下标超出范围＆＃34;错误。我现在已经玩了大约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

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

1 个答案: