CODEWITHSUNDEEP
vbaexcel
WaltVinegar
WaltVinegar

Reputation: 5

copy from multiple sheets to seperate workbook

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?

Upvotes: 0

Views: 100

Answers (1)

Rory
Rory

Reputation: 34075

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

Upvotes: 1

Related Questions