Copying values from one sheet to another

Question

I am trying to copy values from one sheet to another using loop with two conditions and it is very slow. Removing conditions from code doesn't have any effect on the speed of the execution. I already have sample sheet where everything is done with functions (if/match/index...) but I would like to remove all functions from this workbook.

Here is the code :

Option Explicit
Private Sub AnalitSample()
 Dim WSS As Worksheet
 Set WSS = Sheets("Source")
 Dim WSD As Worksheet
 Set WSD = Sheets("Dest")
 Dim col As String
 col = "B"
 Dim rCell As Range
 Dim rRng As Range
 Set rRng = WSS.Range("B2:B4000")
 Dim i As Integer
 i = 2
 WSD.Range("B2:G4000").ClearContents
 For Each rCell In rRng.Cells
 If rCell.Value <> "" Then
 If Len(rCell.Value) > 3 Then
 WSD.Range(col & i).Value = rCell.Offset(0, 0).Value
 WSD.Range(col & i).Offset(0, 1).Value = rCell.Offset(0, 1).Value
 WSD.Range(col & i).Offset(0, 2).Value = rCell.Offset(0, 4).Value
 WSD.Range(col & i).Offset(0, 3).Value = rCell.Offset(0, 5).Value
 WSD.Range(col & i).Offset(0, 4).Value = rCell.Offset(0, 6).Value
 WSD.Range(col & i).Offset(0, 5).Value = rCell.Offset(0, 9).Value
 i = i + 1
 End If
 End If
 Next rCell
End Sub

I am asking for a few suggestions on how to speed up this kind of code (for each loop), that I was avoiding in the past because of the speed.

• Jovica: I've added name of the subroutine and end sub, now it's the complete code. By the way I like that rule, it's much easier to figure out what is going on if the whole code is provided.

Answer 1

Lowest Hanging VBA Fruit:

Public Sub ()
 Application.ScreenUpdating = False
 Application.EnableEvents= False
 Application.Calculation= XlManual
 ...
 Code
 ...
 Application.ScreenUpdating = True
 Application.EnableEvents= True
 Application.Calculation= XlAutomatic
End Sub

Every time you access the worksheet, events trigger, formulas recalculate and Excel re-draws the screen.
You're accessing the worksheet 4,000 times.
Turning those options off will make your code inordinately faster. Just make sure they get reset back to normal at the end.

---

Superfluous Logic

If rCell.Value <> "" Then
 If Len(rCell.Value) > 3 Then

If Len(value) > 0 then, by definition, value is not an empty string. So you can just drop rCell.Value <> "".

---

Use row/column numbers. not Strings and offsets.

This is more of a good practice thing. Get in the habit of using Cells(Row, Column) instead of Range("B" & number).

Like so:

Dim finalRow As Long
Dim iRow As Long
Const TARGET_COL As Long = 2
Dim cellText As String
For iRow = 2 To finalRow
 cellText = WSS.Cells(iRow, TARGET_COL).Text
 If Len(cellText) > 3 Then
 '/ Do Stuff
 End If
Next iRow

• Jovica: I can not believe it, thank you so much. I stopped using ScreenUpdating 'cause I never tested it for speed. I spent so much time in the past searching for faster way for everything and there it is, so simple.
• Jovica: -Len(rCell.Value) > 3 is necessary, so that account number (first column) with length of 3 chars is ignored, is that's what you meant.
• Comintern: Yep, string concats are slow - offsets are even slower. Granted, the OP's code runs in ms range on machine with random test data, but it scales so much better.
• Jovica: Thank you for that last part/edit, it's definitely faster now, also it's so much better to learn new things this way.

Answer 2

TL;DR - Minimise calls to Range.Value... work on VBA arrays...

Turning off screen updates etc will have an effect, but I'd suggest the biggest single thing slowing down your code is that you're reading and writing cells one at a time... the overhead in the API is killing you.

If you ask for the value of a single cell range, you get a single value, but if you ask for the value of larger range you get a 2D array of values.

So first thing, read all of column B into an array and then walk the array - this is much faster than asking for each cell in turn

Set rRng = WSS.Range("B1:B4000")
dim columnB
columnB = rRng.value

so you now have an array of just column B as VBA values... (note arrays read like this ALWAYS start with an lbound of 1).

Note I've also started from row 1 (not 2) - it just makes it easier not to suffer off-by-one errors later on :)

Now with the loop I'm going to iterate by row number, not cell, and get the value and force it to a string and then check its length

dim row as long
For row = 2 to ubound(columnb,1)
 If len("" & columnb(row,1)) > 3 Then

This alone will walk through all the rows, skipping those you don;t care about, much faster.

Now when you find a row you want to copy, read the values in one read, assemble your output, and write it in one call (the gain you make by using an array is bigger on writes than it is on reads).

But first, lets get those values in a single read - looks like you're reading column 2 to column 11 - again to make it easier to read I'm going to grab an extra cell

dim srcvals
srcvals = range(wsd.cells(row,1), wsd.cells(row, 11)).value

So we now have a 1 x 11 array of values. You're writing these into 6 columns, so assemble them in another array

dim tgtvals(1 to 1, 1 to 6)
tgtvals(1,1) = srcvals(1,2) ' col B
tgtvals(1,2) = srcvals(1,3)
tgtvals(1,3) = srcvals(1,6)
tgtvals(1,4) = srcvals(1,7)
tgtvals(1,5) = srcvals(1,8)
tgtvals(1,6) = srcvals(1,11)

Then write them

range(wsd.cells(i,1), wsd.cells(i,6)).value = tgtvals

Now I haven't got access to my Excel at the moment, so you'll have to glue those bits together yourself (and correct for where other people have suggested things) but I dare say that'll make things much faster.

You're now doing only 1 read to work out which rows to work on, and then one read and one write per actual row.

You could make it faster still be gathering all the rows you want to write into one large array and writing that at the end, but try this for now and see what improvement you get.

• Kaz: Hi Tim and welcome to Code Review. Always nice to see new contributors. Feel free to Come say hi

Answer 3

@Zak beat me to the performance tune-ups, so I'll address the eye-popping low-hanging fruit.

Indentation

Your indentation started off pretty well:

For Each rCell In rRng.Cells
 If rCell.Value <> "" Then
 If Len(rCell.Value) > 3 Then

And then things got out of hand and ended up outright confusing - it took me several reads to realize that was not a nested loop:

 End If
 End If
 Next rCell

You can use the latest MZ-Tools or Rubberduck 2.0 (beta) to automatically and consistently indent your code, to turn this:

For Each rCell In rRng.Cells
 If rCell.Value <> "" Then
 If Len(rCell.Value) > 3 Then
 'code
 End If
 End If
 Next rCell

Into this:

For Each rCell In rRng.Cells
 If rCell.Value <> "" Then
 If Len(rCell.Value) > 3 Then
 'code
 End If
 End If
Next rCell

...as easily as pressing a Ctrl+P (for "indent procedure") hotkey.

---

Naming

Dim WSS As Worksheet
Set WSS = Sheets("Source")
Dim WSD As Worksheet
Set WSD = Sheets("Dest")

I love that you're declaring variables as close as possible to their first usage, this is a great habit you've got here, don't lose it! ...actually the declaration of rCell could be moved further down, right above the loop.

Except WSS and WSD are outright awful names. Oh, I get it - "WS" for "Workshet", and "S" for "Source" and "D" for "Destination". Why not have this then?

Dim sourceSheet As Worksheet
Set sourceSheet = Sheets("Source")
Dim destSheet As Worksheet
Set destSheet = Sheets("Dest")

Actually, if Sheets("Source") and Sheets("Dest") always exist in that workbook, and they have that same meaning all the time, then you don't even need to declare local object variables for them - Excel VBA already gives you global ones. You can name your worksheets using the Properties toolwindow (Ctrl+F4) and setting the (name) property. Then you can refer to them in code using whatever identifier you gave them - and that eliminates two declarations and two assignments already.

i would be better off as currentRow or something that indicates that it's used as a row number.

I really like that you're referring explicitly to .Value instead of relying on obnoxious default members - that's another great habit you shouldn't lose!

---

This seems rather arbitrary:

Set rRng = WSS.Range("B2:B4000")

If that's supposed to be "all used cells in column B" then you have a timebomb bug waiting to happen here.

This excellent SO answer describes the most reliable way to find the last row. Use it.

---

I don't really see a need for a For Each loop here - you're already maintaining a "current row" counter, seems a For loop would do just fine, and reference fewer objects.

• Jovica: Thank you for the tips, this a great help. In general I like my code to be clear for reading, but sometimes frustrations gets the better of me.

Answer 4

Maybe this would help a bit, as well, in place of your current loop (in addition to the excellent answer above):

For Each rCell In rRng.Cells
 If rCell.Value <> "" Then
 If Len(rCell.Value) > 3 Then
 With WSD.Range(col & i)
 .Value = rCell.Offset(0, 0).Value
 .Offset(0, 1).Value = rCell.Offset(0, 1).Value
 .Offset(0, 2).Resize(1, 3).Value = rCell.Offset(0, 4).Resize(1, 3).Value
 .Offset(0, 5).Value = rCell.Offset(0, 9).Value
 End With
 i = i + 1
 End If
 End If
Next rCell

The With ... End With block is a simplified structure so the object is read only once and not repeatedly. The resize property eliminates the need to read the two additional lines of code you had by simply turning, for example, Range("A1") to Range("A1:A3") and writing the latter to the other worksheet.