0

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?

2
  • Where are you actually trying to paste to - which cells?
    – Rory
    Oct 9, 2017 at 11:58
  • it just needs to start off pasting into A1 and B1 [it's only copying two cells of data from each row], but then move down one row on each iteration of the loop. I'm a total novice at VBA [as you can tell], so it's taking longer than it probably should. Oct 9, 2017 at 12:05

1 Answer 1

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
6
  • I'm getting a "Subscript out of range" error for 'Set wshold = wbhold.Worksheets("Hold Data")' Oct 9, 2017 at 12:22
  • Just double-checked, and the sheet names match. I was getting that error with my code earlier, too, which is why the line was removed on the original question. Oct 9, 2017 at 12:34
  • 1
    @WaltVinegar Either you've got the wrong workbook, or the sheet name is wrong. There is no other possibility.
    – Rory
    Oct 9, 2017 at 12:40
  • Sorted that - I think it was vbecause I was trying to import the data into the worksheet which had the command button. I've changed it to save to a separate xlsx file, and am not getting an error for that anymore. However, now it's copying the entire worksheet, rather than just the specified cells, and simultaneously giving an error: "you can't paste this here because the copy area and paste area aren't the same size" for the line: 'rng.Copy wshold.Cells(outrow, "A")' Oct 9, 2017 at 12:57
  • I've just corrected an error in the code - can you try the new version?
    – Rory
    Oct 9, 2017 at 12:59

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.