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.

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

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.

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.

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.