1

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

Improve this question
2
  • 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? Commented Nov 15, 2013 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. Commented Nov 16, 2013 at 5:52

4 Answers 4

Reset to default
0

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
Improve this answer
Sign up to request clarification or add additional context in comments.

Comments

0

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
Improve this answer

Comments

0

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
Improve this answer

2 Comments

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?
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...
0

@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

Improve this answer

Comments

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.