• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Improve Performance of Excel vba Code

Vineshan

New Member
I am working with two sheets: -
Sheet1 has a text value that I am adding into sheet2 but I am adding this value multiple times based on the number of weeks within a date range selected. If my date range has 4 weeks in between, then I add the text value into 4 rows of the column selected. If there are 5 weeks, then I add the value into 5 rows. My problem with this is performance. On average, I have about 250 records in sheet1 but there are duplicates which I check for and ignore and then only add the ones that are not already added. Doing this takes between 10 - 12 seconds which is a bit too long. I have mentioned 1 column but I do this for many columns using the same method and this takes about 4 minutes. How can I improve the performance. This is what my code looks like

>>> use code - tag <<<
Code:
Dim A, AB, B, BA, Y, V, L&, X, C, R&, S, BB

Set s1 = ActiveWorkbook.Worksheets("System1") 'These names are not used
Set s2 = ActiveWorkbook.Worksheets("System2")
Set s3 = ActiveWorkbook.Worksheets("System3")
Set s4 = ActiveWorkbook.Worksheets("System4")
Set s5 = ActiveWorkbook.Worksheets("System5")

    On Error GoTo EH


            'Get the values of the first column
        A = s2.UsedRange.Columns(intPersonID).Value

        ReDim V(1 To (UBound(A)) * 10, 0)

            N = 1
            S = 1
            R = 0

            AZ =  1

            BB = ""

        For BA = 1 To UBound(A)

            If BA = 1 Then

                V(R + N, 0) = "ID"

                R = R + 1

                Set strChar = s4.Range(Split(Cells(1, AZ).Address, "$")(1) & "1")

                BB = "ID"

                strChar.Resize(R) = V

            Else

                If CStr(A(BA, 1)) <> CStr(BB) Then

                    For AB = 1 To 5 'intWeeks

                            V(R + N, 0) = "'" & (A(BA, 1))

                            R = R + 1

                            Set strChar = s4.Range(Split(Cells(1, AZ).Address, "$")(1) & "1")

                            strChar.Resize(R) = V

                            BB = (A(BA, 1))

                    Next

                End If

            End If

        Next

EH:
        Resume Next

End Sub
 
Last edited by a moderator:
Vineshan
Code's the 1st line should have word Sub and Sub's name.
With a sample Excel file, which has data and expected results would help You a lot to get answers.
 
Thank you...

>>> use code - tags <<<
Code:
Sub PopulateByWeekPersonID()

Dim A, AB, B, BA, Y, V, L&, X, C, R&, S, BB

Set s1 = ActiveWorkbook.Worksheets("System1")
Set s2 = ActiveWorkbook.Worksheets("System2")
Set s3 = ActiveWorkbook.Worksheets("System3")
Set s4 = ActiveWorkbook.Worksheets("System4")
Set s5 = ActiveWorkbook.Worksheets("System5")

    On Error GoTo EH

            'Get the values of the first column
        A = s2.UsedRange.Columns(intPersonID).Value

        ReDim V(1 To (UBound(A)) * 10, 0)

            N = 1
'            S = 1
            R = 0

            AZ = AZ + 1

            BB = ""

        For BA = 1 To UBound(A)

            If BA = 1 Then

                V(R + N, 0) = "ID"

                R = R + 1

                Set strChar = s4.Range(Split(Cells(1, AZ).Address, "$")(1) & "1")

                BB = "ID"

                strChar.Resize(R) = V

            Else

                If CStr(A(BA, 1)) <> CStr(BB) Then

                    For AB = 1 To intWeeks

                            V(R + N, 0) = "'" & (A(BA, 1))

                            R = R + 1

                            Set strChar = s4.Range(Split(Cells(1, AZ).Address, "$")(1) & "1")

                            strChar.Resize(R) = V

                            BB = (A(BA, 1))

                    Next

                End If

            End If

        Next

EH:
        Resume Next

End Sub
 

Attachments

  • SampleData.xlsm
    11.3 KB · Views: 3
Last edited by a moderator:
I have attached some sample data but consider that these records can reach more than 5000...hence my performance issues
 
Vineshan
Okay - a sample file, but
... with Your writing, You've mentioned Sheet1 and Sheet2 - I can see only Sheet1 ... of course, I could add there it.
... Your above code has other sheets ... and Your code is missing for some reason?
Where is expected result?
Which makes Your duplicates? Sheet1 has none ...
or which columns do You check?


about Performance ...
Code:
Sub PopulateByWeekPersonID()
    With Application
        cm = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    
' Your code here
    
    With Application
        .Calculation = cm
        .ScreenUpdating = True
    End With
End Sub
 
Forgive me for not adding all of the information as some of it is very sensitive and I am restricted in what I can share...however, thank you for your code. This is absolutely perfect and makes the world of difference.
 
Vineshan
If even sample data is very sensitive then this case is challenge to solve.
.. based You code - there could be 'something' which could do other ways, but only after You could give details what to do?
 
Back
Top