Can this macro code be optimized?

Question

Thank you in advance for your assistance.

I am running a macro where I have a list of unique records in worksheet "Sheet2" and it will search for these entries in Worksheet "PO_Details" and once it finds the details it will add these fields in "Sheet2" and append to values. So result could be like this:

A; B; C etc depending on the number of records in PO details

My PO_details sheet has 8700 records

My Sheet2 has 6700 unique records

The macro works fine but the only concern is when I run this code it takes about 10 minutes to run. I fear the performance will reduce when the unique records increase to a higher number.

Is there anything I need to do to optimize this code

I am a beginner at this and would appreciate any help :)

Sub Macro3()

    ' Keyboard Shortcut: Ctrl+u

    Dim PO_Name As String
    Dim Finalrow As Integer
    Dim i As Integer
    Dim fValue As String
    Dim Tmp As String
    Dim x As Integer
    Dim fValue1 As String
    Dim Tmp1 As String
    Dim fValue2 As String
    Dim Tmp2 As String
    Dim fValue3 As String
    Dim Tmp3 As String

    Sheets("Sheet2").Range("b2:f20000").ClearContents

    Finalrow = Sheets("PO_Details").Range("H30000").End(xlUp).Row
    Finalrow_unique = Sheets("Sheet2").Range("a30000").End(xlUp).Row

    For x = 2 To Finalrow_unique
        PO_Name = Sheets("Sheet2").Range("a" & x).Value

        fValue = " "
        fValue1 = " "
        fValue2 = " "
        fValue3 = " "

        For i = 2 To Finalrow

            If Sheets("PO_Details").Range("h" & i) = PO_Name Then

                'Cells(i, 1) = PO_Name Then
                Tmp = Sheets("PO_Details").Range("c" & i).Value
                fValue = fValue & ";" & Tmp
                Tmp1 = Sheets("PO_Details").Range("d" & i).Value
                fValue1 = fValue1 & ";" & Tmp1
                Tmp2 = Sheets("PO_Details").Range("b" & i).Value
                fValue2 = fValue2 & ";" & Tmp2
                Tmp3 = Sheets("PO_Details").Range("e" & i).Value
                fValue3 = fValue3 & ";" & Tmp3

            End If
        Next i

        Sheets("sheet2").Range("b" & x) = fValue
        Sheets("sheet2").Range("c" & x) = fValue1
        Sheets("sheet2").Range("d" & x) = fValue2
        Sheets("sheet2").Range("e" & x) = fValue3

    Next x

End Sub

Put Option Explicit at top of module and you will realise that Finalrow_unique is not declared. Declare all Integer variables as Long. Fully qualify your references as the reference to the activeworkbook is implicit in the above e.g. You could put With ActiveWorkbook and then afterwards indicate the Sheets relationship with .Sheets("PO_Details") etc. For actual speed you might consider using arrays to hold data. — QHarr, Oct 23 '17 at 06:26
tip: no need for intermediate variables ... do this: `fValue = fValue & ";" & Sheets("PO_Details").Range("c" & i).Value` — jsotola, Oct 23 '17 at 06:31
tip2: Always [use `Long` instead of `Integer`](https://stackoverflow.com/a/26409520/3219613), especially when dealing with row counts. Excel has more rows than `Integer` can handle. — Pᴇʜ, Oct 23 '17 at 07:25
Thank you for your inputs, i have modified the code to get rid of the tmp variable, also have made references to active workbook and added option explicit and replaced integer as long. Is there any example you would recommend for using array instead of the current setup in macro. — preetham jason, Oct 23 '17 at 07:31
Added fast working example allowing you to perform all string combinations within a datafield array containing all necessary data in one and writing it back again in one code line instead of looping through a range. — T.M., Oct 23 '17 at 08:26
Thank you everyone for helping me out with this, i shall try out these suggestions today :) — preetham jason, Oct 23 '17 at 08:58
@preethamjason, welcome to the community. BTW, would suggest to read the tips at https://stackoverflow.com/help/how-to-ask (e.g. Write a title that summarizes the specific problem). — T.M., Oct 23 '17 at 09:35
Might be better to ask on https://codereview.stackexchange.com/. — Darren Bartrup-Cook, Oct 23 '17 at 09:54

Michael · Answer 1 · 2017-10-23T07:29:54.337

The code has two main performance problems:

It is reading data from the spreadsheet one cell at a time. Every time you get data from Excel to use in VBA or write data to a cell from VBA there is processing overhead. Reading an entire range into a single array variable in VBA and then looping through that array is many times faster.
It is looping through all rows in PODetails for every row in sheet2. This is the slowest and most repetitive search possible. There are many ways this could be made more efficient.

Here's one possible approach in pseudo-code. The idea is to loop through PODetails only once. Constructing and copying values as you go. This could still be made a lot more efficient in quite a few ways, but this a pretty simple way to still get a huge improvement.

Sort both lists in ascending order by PO_Name
Read all data from PO_Details into a single array variable PODetails
From PODetails, Set CurrentPOName = first PO_Name
Set CurrentfValue = first fValue 
Set CurrentfValue1 = first fValue1
Set CurrentfValue2 = first fValue2 
Set CurrentfValue3 = first fValue3 
Set UniquePORowCounter = 1
For PODetailsRowCounter = 2 to PODetails.Rows
    If PODetails(PODetailsRowCounter).POName = CurrentPOName Then
        Append fValue into CurrentfValue
        Append fValue1 into CurrentfValue1
        Append fValue2 into CurrentfValue2
        Append fValue3 into CurrentfValue3
    Else
        Use fast double vlookup to find the row on which CurrentPOName exists in UniquePO
        If CurrentPOName is found, then save fValues onto UniquePO sheet (if not found, then ignore and continue)
        Set CurrentPOName = PODetailsRow(PODetailsRowCounter).POName
        Set CurrentfValue = PODetailsRow(PODetailsRowCounter).CurrentfValue
        Set CurrentfValue1 = PODetailsRow(PODetailsRowCounter).CurrentfValue1
        Set CurrentfValue2 = PODetailsRow(PODetailsRowCounter).CurrentfValue2
        Set CurrentfValue3 = PODetailsRow(PODetailsRowCounter).CurrentfValue3
    End If
Next PODetailsRowCounter

jsotola · Answer 2 · 2017-10-23T08:37:44.740

here is your code rewritten to use arrays ... untested

Sub Macro3()
    '
    ' Macro3 Macro
    '
    ' Keyboard Shortcut: Ctrl+u
    '
    Dim PO_Name As String
    Dim Finalrow As Long          ' use long here. you may go past 32k rows in the future
    Dim Finalrow_unique As Long

    Dim i As Integer
    Dim x As Integer

    Dim fValue1 As String   ' changed names here so that everything lines up
    Dim fValue2 As String
    Dim fValue3 As String
    Dim fValue4 As String


    Sheets("Sheet2").Range("b2:f20000").ClearContents

    Finalrow = Sheets("PO_Details").Range("H30000").End(xlUp).Row
    Finalrow_unique = Sheets("Sheet2").Range("a30000").End(xlUp).Row

    Dim colB As Variant
    Dim colC As Variant
    Dim colD As Variant
    Dim colE As Variant
    Dim colH As Variant

    colB = Sheets("PO_Details").Range("b1:b" & Finalrow) ' pull data from the five ranges into arrays
    colC = Sheets("PO_Details").Range("c1:c" & Finalrow)
    colD = Sheets("PO_Details").Range("d1:d" & Finalrow) ' start at first row
    colE = Sheets("PO_Details").Range("e1:e" & Finalrow) ' so that the loop in the code below
    colH = Sheets("PO_Details").Range("h1:h" & Finalrow) ' can start at 2 as before


    For x = 2 To Finalrow_unique

        fValue1 = " "
        fValue2 = " "
        fValue3 = " "
        fValue4 = " "

        PO_Name = Sheets("Sheet2").Range("a" & x).Value

        For i = 2 To Finalrow
            If colH(i, 1) = PO_Name Then
                fValue1 = fValue1 & ";" & colC(i, 1) ' the range actually is a 2D array
                fValue2 = fValue2 & ";" & colD(i, 1)
                fValue3 = fValue3 & ";" & colB(i, 1)
                fValue4 = fValue4 & ";" & colE(i, 1)
            End If
        Next i

        Sheets("sheet2").Range("b" & x) = fValue1
        Sheets("sheet2").Range("c" & x) = fValue2
        Sheets("sheet2").Range("d" & x) = fValue3
        Sheets("sheet2").Range("e" & x) = fValue4

    Next x

End Sub

Friendly hint :-) ... think the `If` condition should be `If colH(i, 1) = PO_Name Then` because you are using 2dim arrays for each 'column'. BTW, there remains a forgotten declaration of `Finalrow_unique" from OP, too. — T.M., Oct 23 '17 at 08:35

T.M. · Answer 3 · 2017-10-23T09:22:00.313

You can always speed it up considerably using arrays instead of Looping through ranges. I added a timer to check this. This example allows to perform all string combinations within a datafield array containing all necessary data in one and writing it back again in one code line instead of looping through a range:

Code

Option Explicit

Sub Macro3a()
'
' Macro3 Macro
'
' Keyboard Shortcut: Ctrl+u
'
Dim v, v2   ' Variant
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim t        As Double
Dim PO_Name As String
Dim Finalrow As Long
Dim Finalrow_unique As Long
Dim i As Long
Dim x As Long
Dim fValue As String
Dim fValue1 As String
Dim fValue2 As String
Dim fValue3 As String
' stop watch
  t = Timer
' set worksheets to memory
  Set ws = ThisWorkbook.Worksheets("PO_Details")  ' details
  Set ws2 = ThisWorkbook.Worksheets("Sheet2")     ' target sheet with unique values
' clear contents in target sheet
  ws2.Range("B:F").ClearContents
' define last rows
  Finalrow = ws.Range("H" & ws.Rows.Count).End(xlUp).Row
  Finalrow_unique = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
' get values to one based 2dim arrays
  v = ws.Range("A1:H" & Finalrow).Value
  v2 = ws2.Range("A1:E" & Finalrow_unique).Value

' loop thru unique values
For x = 2 To Finalrow_unique
    PO_Name = v2(x, 1)

    fValue = " "
    fValue1 = " "
    fValue2 = " "
    fValue3 = " "
    ' get string values
    For i = 2 To Finalrow

        If v(i, 8) = PO_Name Then

            fValue = fValue & ";" & v(i, 3)
            fValue1 = fValue1 & ";" & v(i, 4)
            fValue2 = fValue2 & ";" & v(i, 2)
            fValue3 = fValue3 & ";" & v(i, 5)

        End If
    Next i

' fill in target columns B:E in sheet2 (column A remains unchanged)
v2(x, 2) = fValue
v2(x, 3) = fValue1
v2(x, 4) = fValue2
v2(x, 5) = fValue3

Next x

' write array v2 back to sheet2
ws2.Range("A1:E" & Finalrow_unique).Value = v2

Debug.Print "Time needed: " & Format(Timer - t, "0.00") & " seconds."

End Sub

Note

All your fValue variables are left unchanged in the above code. In order to make code more readable, I'd suggest, however, to rename them according to your column letters, e.g. fColD instead of fValue2 or fColE instead of fValue3. Furthermore, you could try to use a Type Definition, sure you'll find something at SO.

score 0 · Answer 4 · answered Oct 23 '17 at 08:10

As mentioned in previous answers you can speed up code by not looping via VBA sheet PO_Details.

I.e. you can use built in function Find to search corresponding row in PO_Details.

Sub Macro3()
'
' Macro3 Macro
'
' Keyboard Shortcut: Ctrl+u
'
Dim PO_Name As String
Dim Finalrow As Integer
Dim Finalrow_unique As Integer
Dim i As Integer
Dim fValue As String
Dim Tmp As String
Dim x As Integer
Dim fValue1 As String
Dim Tmp1 As String
Dim fValue2 As String
Dim Tmp2 As String
Dim fValue3 As String
Dim Tmp3 As String
Dim search_value As String

Sheets("Sheet2").Range("b2:f20000").ClearContents

Finalrow = Sheets("PO_Details").Range("H30000").End(xlUp).Row
Finalrow_unique = Sheets("Sheet2").Range("a30000").End(xlUp).Row

For x = 2 To Finalrow_unique
    PO_Name = Sheets("Sheet2").Range("a" & x).Value

    fValue = " "
    fValue1 = " "
    fValue2 = " "
    fValue3 = " "

    Dim c As Range
    With Sheets("PO_Details").Range("h1:h30000")
        Set c = .Find(PO_Name, LookIn:=xlValues)
        If Not c Is Nothing Then
            i = c.Row
            Tmp = Sheets("PO_Details").Range("c" & i).Value
            fValue = fValue & ";" & Tmp
            Tmp1 = Sheets("PO_Details").Range("d" & i).Value
            fValue1 = fValue1 & ";" & Tmp1
            Tmp2 = Sheets("PO_Details").Range("b" & i).Value
            fValue2 = fValue2 & ";" & Tmp2
            Tmp3 = Sheets("PO_Details").Range("e" & i).Value
            fValue3 = fValue3 & ";" & Tmp3
        End If
    End With

    Sheets("sheet2").Range("b" & x) = fValue
    Sheets("sheet2").Range("c" & x) = fValue1
    Sheets("sheet2").Range("d" & x) = fValue2
    Sheets("sheet2").Range("e" & x) = fValue3
Next x

End Sub

Can this macro code be optimized?

4 Answers4