Excel VBA to loop and copy paste on variable ranges to variable ranges

Question

I have a loop which changes the ranges of the copy cells and the paste cells. This is working with Select - but is causing the code to run slowly. How can I improve this to not use the Select?

    Dim i As Long
Dim x As Long
Dim y As Long

Dim lastcell As Long

Dim countnonblank As Integer, myrange As Range
Set myrange = Sheets("Label Create Worksheet").Columns("A:A")
countnonblank = Application.WorksheetFunction.CountA(myrange)

lastcell = Int(countnonblank / 9) + 1

For x = 0 To lastcell

i = i + 1

y = y + IIf(x = 0, 0, 9)




Sheets("Label Create Worksheet").Select
Range(Cells(2 + y, 1), Cells(2 + y, 6)).Select
Selection.Copy

Sheets("Data").Select
Cells(1 + i, 1).Select
ActiveSheet.Paste


Sheets("Label Create Worksheet").Select
Range(Cells(3 + y, 1), Cells(3 + y, 6)).Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Data").Select
Cells(1 + i, 11).Select
ActiveSheet.Paste

Sheets("Label Create Worksheet").Select
Range(Cells(4 + y, 1), Cells(4 + y, 6)).Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Data").Select
Cells(1 + i, 21).Select
ActiveSheet.Paste

Sheets("Label Create Worksheet").Select
Range(Cells(5 + y, 1), Cells(5 + y, 6)).Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Data").Select
Cells(1 + i, 31).Select
ActiveSheet.Paste

Sheets("Label Create Worksheet").Select
Range(Cells(6 + y, 1), Cells(6 + y, 6)).Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Data").Select
Cells(1 + i, 41).Select
ActiveSheet.Paste

Sheets("Label Create Worksheet").Select
Range(Cells(7 + y, 1), Cells(7 + y, 6)).Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Data").Select
Cells(1 + i, 51).Select
ActiveSheet.Paste

Sheets("Label Create Worksheet").Select
Range(Cells(8 + y, 1), Cells(8 + y, 6)).Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Data").Select
Cells(1 + i, 61).Select
ActiveSheet.Paste

Sheets("Label Create Worksheet").Select
Range(Cells(9 + y, 1), Cells(9 + y, 6)).Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Data").Select
Cells(1 + i, 71).Select
ActiveSheet.Paste

Sheets("Label Create Worksheet").Select
Range(Cells(10 + y, 1), Cells(10 + y, 6)).Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Data").Select
Cells(1 + i, 81).Select
ActiveSheet.Paste

Next x

Set myrange = Nothing

I'm curious what "etc. etc." means in your example code. I tried to understand from what you've provided what the data must look like, but it is somewhat mysterious. hessr17's suggestion below will get rid of the selections, but I'm suspicious that your poor performance may have something to do with your loop structure as well. Can you post complete code? — Instant Breakfast, Nov 15 '13 at 21:20
The etc, etc is the continuation of the next sections to be copied. The Label Create worksheet has rows of data (10 colums wide). The Data sheets needs this data copied into the first 10 columsn, then the next 10 columns - 9 times before it moves to the next row. The code change below works for the first loop, but fails on the second loop. I am not sure how to re-enter all of my code on here, as this is my first post. — user2997192, Nov 16 '13 at 05:52

score 0 · Answer 1 · answered Nov 15 '13 at 17:51

Your copy and paste should be something similar to this. All of those selects slow everything down significantly.

        Sheets("Label Create Worksheet").Range(Cells(2 + y, 1), Cells(2 + y, 10)).Copy

        Sheets("Data").Cells(1 + i, 1).PasteSpecial Paste:=xlPasteValues

score 0 · Answer 2 · answered Nov 16 '13 at 10:18

Many thanks. Got the answer below in case anybody else needs it:

Dim i As Long, x As Long, y As Long, lastcell As Long, countnonblank As Long

Dim myrange As Range, wsLCW As Worksheet, wsDAT As Worksheet



Set wsLCW = Sheets("Label Create Worksheet")

Set wsDAT = Sheets("Data")



With wsLCW

    Set myrange = .Columns("A:A")

    countnonblank = Application.CountA(myrange)

    lastcell = Int(countnonblank / 9) + 1

    For x = 0 To lastcell

        i = i + 1

        y = y + IIf(x = 0, 0, 9)



        .Cells(2 + y, 1).Resize(, 10).Copy Destination:=wsDAT.Cells(1 + i, 1)

        .Cells(3 + y, 1).Resize(, 10).Copy Destination:=wsDAT.Cells(1 + i, 11)

        .Cells(4 + y, 1).Resize(, 10).Copy Destination:=wsDAT.Cells(1 + i, 21)

        .Cells(5 + y, 1).Resize(, 10).Copy Destination:=wsDAT.Cells(1 + i, 31)

        .Cells(6 + y, 1).Resize(, 10).Copy Destination:=wsDAT.Cells(1 + i, 41)

        .Cells(7 + y, 1).Resize(, 10).Copy Destination:=wsDAT.Cells(1 + i, 51)

        .Cells(8 + y, 1).Resize(, 10).Copy Destination:=wsDAT.Cells(1 + i, 61)

        .Cells(9 + y, 1).Resize(, 10).Copy Destination:=wsDAT.Cells(1 + i, 71)

        .Cells(10 + y, 1).Resize(, 10).Copy Destination:=wsDAT.Cells(1 + i, 81)

    Next x

End With



Set myrange = Nothing

Set wsLCW = Nothing

Set wsDAT = Nothing

score 0 · Answer 3 · answered Nov 16 '13 at 11:43

Looking at your code it appears that your data in Label Create Worksheet is in columns A to F and you want to place it in sheet Data on row 2 and spaced out at points 1, 11, 21 etc.

This code I tested and worked for that scenario:

Sub ReadWriteData()
    Dim data As Range, arr(), rows As Integer, rw As Integer, col As Integer, startPos As Integer

    Set data = Worksheets("Label Create Worksheet").Range("A2:F" & Range("A2").End(xlDown).Row)
    arr() = data

    With Worksheets("Data")
        For rw = 1 To data.rows.Count
            For col = 1 To data.Columns.Count
                .Cells(2, startPos + col) = data(rw, col)
            Next col
            startPos = startPos + (rw * 10)
        Next rw
    End With
End Sub

Testing this, it does not seem to do exactly what the user has in mind (and I think you maybe meant to say `rw + 10` instead of `rw*10`? — Instant Breakfast, Nov 30 '13 at 20:12
I recall I had to try and 'guess' what was being asked by running the OP's code. From memory I think it should be `rw * 10` as that sets the spacing for the columns e.g. 10, 20, 30 etc... — Alex P, Dec 01 '13 at 09:24

score 0 · Answer 4 · answered Nov 30 '13 at 22:58

@Alex P's idea for using a more efficient loop structure is a good one, though his code produces a different result than that provided by you. I adapted his idea to your need, and I think the following code does what you are doing with yours but a little more efficiently.

Sub ReadWriteData2()

'~~>Dim variables and set initial values
    Worksheets("Label Create Worksheet").Activate
    Dim rngDataSource As Range
        Set rngDataSource = Worksheets("Label Create Worksheet").Range(Cells(2, 1), _
                                Cells(Range("A2").End(xlDown).Row, _
                                Range("A2").End(xlToRight).Column))
    Dim intSourceRow As Integer
    Dim intSourceColumn As Integer
    Dim intPasteRow As Integer
        intPasteRow = 2
    Dim intPasteColumn As Integer
        intPasteColumn = 1
    Dim intTotalRows As Integer
        intTotalRows = rngDataSource.rows.Count

'~~>Loop to transfer data

    With Worksheets("Data")
        For intSourceRow = 1 To intTotalRows
            If intPasteColumn > 81 Then intPasteColumn = 1
            For intSourceColumn = 1 To 10
                .Cells(intPasteRow, (intPasteColumn + intSourceColumn) - 1).value = _
                 rngDataSource(intSourceRow, intSourceColumn).value
            Next intSourceColumn
            intPasteColumn = intPasteColumn + 10
            intPasteRow = 2 + (Int(intSourceRow / 9))
        Next intSourceRow
    End With
End Sub

Using the timer function to test both, I found this code completes the task about four times faster than yours (I used the new code you posted as an answer to coding the task without the .select phrases). If your data set will end up being very large, or if you are still having slow performance, you might want to use something similar

Excel VBA to loop and copy paste on variable ranges to variable ranges

4 Answers4