Can you speed up my VBA please

Montichristo

New Member
Joined
Aug 25, 2016
Messages
10
Hi,

I have ~95'000 line to catagorise using the below codes. I run the first then the second. I'm using an array in both (i think) but the data is processed very slowly. Can anyone see where I could speed it up please.

Sub Breakdownone()

Dim vdata() As Variant
Dim r As Long
Dim c As Long
Dim maxrows As Long
Dim range As String
Dim ce17string As String
Dim cs16string As String
Dim c1string As String
Dim descrip As String
Dim c1char1 As String


Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
ActiveSheet.DisplayPageBreaks = False

c1char1 = Left(c1string, 1)

vdata = ActiveSheet.UsedRange.Value


maxrows = UBound(vdata, 1)
For r = 3 To maxrows
descrip = ""
c1string = vdata(r, 15)
ce17string = vdata(r, 16)
cs16string = vdata(r, 17)
vreturndata = vdata(r, 20)



'ce17string column
Select Case ce17string
Case "1"
descrip = "Hedge Fund"
End Select
If descrip = "" Then
Else
GoTo Assign
End If

'ce16string column
Select Case cs16string
Case "21", "46", "26"
descrip = "Equity"
Case "17", "44", "31", "45", "54"
descrip = "Exchange Traded Fund"
End Select
If descrip = "" Then
Else
GoTo Assign
End If

'c1string column
Select Case c1string
Case "2", "8", "9", "5G"
descrip = "Equity"
Case "6D"
descrip = "Exchange traded Fund"
Case "6C", "6E"
descrip = "Fund"
End Select
If descrip = "" Then
Else
GoTo Assign
End If

'Begins with c1string column
Select Case Left(c1string, 1)
Case "1", "2", "3"
descrip = "Equity"
Case "4", "8", "9"
descrip = "Debt"
Case "5"
descrip = "Derivatives"
Case "C"
descrip = "Commodities"
End Select
If descrip = "" Then
Else
GoTo Assign
End If

Assign:
Worksheets("Client Asset List").Cells(r, 20) = descrip

Application.StatusBar = "Progress: " & r & " of maxrows: " & Format(r / maxrows, "0%")

Next


Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True


End Sub


Here is the second piece of code:


Sub breakdowntwo()

Dim vdata() As Variant
Dim r As Long
Dim c As Long
Dim maxrows As Long
Dim ce17string As String
Dim cs16string As String
Dim c1string As String
Dim descrip As String
Dim descrip2 As String
Dim depotcode As String
Dim predpcode As String
Dim c1char1 As String
Dim Model As String

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

vdata = ActiveSheet.UsedRange.Value

c1char1 = Left(c1string, 1)

maxrows = UBound(vdata, 1)
For r = 3 To maxrows
descrip = ""
descrip2 = ""
depotcode = vdata(r, 7)
c1string = vdata(r, 15)
ce17string = vdata(r, 16)
cs16string = vdata(r, 17)
Model = vdata(r, 23)
predpcode = Left(depotcode, 3)


' Start the section that covers the Hedge Funds code CE17

Select Case ce17string
Case "1"
descrip = "Hedge Fund"
End Select

If descrip = "" Then
Else
GoTo Assign
End If

' Start the section that covers the code CS16

Select Case cs16string
Case "17", "31", "44", "45"
descrip = "Exchange Traded Fund"
Case "21", "46"
descrip = "Exchange Traded Commodity"
Case "3", "6"
descrip = "Depository Receipt"
Case "20", "26"
descrip = "Real Estate Investment Trust"
Case "30"
descrip = "Venture Capital Trust"
Case "43"
descrip = "Limited Partnership/LLP"
End Select

If descrip = "" Then
Else
GoTo Assign
End If

' Start the section that covers the code C1

Select Case c1string
Case "5F"
descrip = "Structured Product"
Case "4B"
descrip = "Equity Link Note"
Case "41", "42", "43", "44", "45", "46", "47", "48", "49", "4A", "4C", "4D", "4E"
descrip = "Corporate Debt"
Case "8A", "8B", "80", "81", "82", "83", "84", "85", "86", "87", "88", "89"
descrip = "Goverment Debt"
Case "9A", "9B", "90", "91", "92", "93", "94", "95", "96", "97", "98"
descrip = "Goverment Debt"
Case "5G"
descrip = "Depository Receipt"
Case "2", "8", "9", "10", "14", "15", "18", "19"
descrip = "Equity"
Case "5D", "51", "5A", "5E"
descrip = "Warrant"
Case "54"
descrip = "Composite Unit"
Case "20", "21", "23", "24", "31", "32", "34", "35"
descrip = "Preference Share"
Case "6C"
descrip = "Mutual Fund"
Case "6D"
descrip = "Closed Ended Fund"
Case "6E"
descrip = "Other Fund"
Case "99"
descrip = "Misc"
End Select

If descrip = "" Then
Else
GoTo Assign
End If

Assign:

Worksheets("Client Asset List").Cells(r, 21) = descrip

'Platform breakdown

If Model = "B" Then
If descrip = "Mutual Fund" Then
Select Case predpcode
Case "FND", "PCI", "PIL"
descrip2 = "Mutual Fund On Platform"
Case Else
descrip2 = "Mutual Fund Off Platform"
End Select

Else
descrip2 = " "
End If
Else
descrip2 = " "
End If


Worksheets("Client Asset List").Cells(r, 22) = descrip2


Application.StatusBar = "Progress: " & r & " of maxrows: " & Format(r / maxrows, "0%")

Next

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.StatusBar = False




Thank you, any help is appreciated.
 

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
Made some changes but will not speedup much as you are dealing with string data

Code:
Sub Breakdownone()
    Dim vdata() As Variant
    Dim r As Long
    Dim c As Long
    Dim maxrows As Long
    Dim range As String
    Dim ce17string As String
    Dim cs16string As String
    Dim c1string As String
    Dim descrip As String
    Dim c1char1 As String
    Dim ws As Worksheet
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    ActiveSheet.DisplayPageBreaks = False
    Set ws = Worksheets("Client Asset List")
    c1char1 = Left(c1string, 1)   '<<< nothing assigned yet,  why try to get left most chr
    vdata = ActiveSheet.UsedRange.Value

    maxrows = UBound(vdata, 1)
    For r = 3 To maxrows
        descrip = ""
        c1string = vdata(r, 15)
        ce17string = vdata(r, 16)  '<<< should this be  ce16string = vdata(r, 16)
        cs16string = vdata(r, 17)  '<<< should this be  ce17string = vdata(r, 17)
        'vreturndata = vdata(r, 20) '<<< not used in procedure nor dimensioned
        'ce17string column
        If ce17string = "1" Then     '<<< changed
            descrip = "Hedge Fund"
            GoTo Assign
        End If
        'ce16string column
        Select Case cs16string
        Case "21", "46", "26"
            descrip = "Equity"
        Case "17", "44", "31", "45", "54"
            descrip = "Exchange Traded Fund"
        End Select
        If descrip <> "" Then GoTo Assign   '<<< changed

        'c1string column
        Select Case c1string
        Case "2", "8", "9", "5G"
            descrip = "Equity"
        Case "6D"
            descrip = "Exchange traded Fund"
        Case "6C", "6E"
            descrip = "Fund"
        End Select
        If descrip <> "" Then GoTo Assign   '<<< changed
        'Begins with c1string column
        Select Case Left(c1string, 1)
        Case "1", "2", "3"
            descrip = "Equity"
        Case "4", "8", "9"
            descrip = "Debt"
        Case "5"
            descrip = "Derivatives"
        Case "C"
            descrip = "Commodities"
        End Select
        If descrip <> "" Then GoTo Assign   '<<< changed
        Exit Sub
Assign:
       ws.Cells(r, 20) = descrip
        'this takes up time why not a message when the procedure is completed
        Application.StatusBar = "Progress: " & r & " of maxrows: " & Format(r / maxrows, "0%")
    Next

    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub
'Here is the second piece of code:

Code:
Sub breakdowntwo()
    Dim vdata() As Variant
    Dim r As Long
    Dim c As Long
    Dim maxrows As Long
    Dim ce17string As String
    Dim cs16string As String
    Dim c1string As String
    Dim descrip As String
    Dim descrip2 As String
    Dim depotcode As String
    Dim predpcode As String
    Dim c1char1 As String
    Dim Model As String
    Dim ws As Worksheet
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Set ws = Worksheets("Client Asset List")
    vdata = ActiveSheet.UsedRange.Value
    c1char1 = Left(c1string, 1)   '<<< nothing assigned yet,  why try to get left most chr
    maxrows = UBound(vdata, 1)
    For r = 3 To maxrows
        descrip = ""
        descrip2 = ""
        depotcode = vdata(r, 7)
        c1string = vdata(r, 15)
        ce17string = vdata(r, 16)
        cs16string = vdata(r, 17)
        Model = vdata(r, 23)
        predpcode = Left(depotcode, 3)

        ' Start the section that covers the Hedge Funds code CE17
        If ce17string = "1" Then     '<<< changed
            descrip = "Hedge Fund"
            GoTo Assign
        End If
        ' Start the section that covers the code CS16
        Select Case cs16string
        Case "17", "31", "44", "45"
            descrip = "Exchange Traded Fund"
        Case "21", "46"
            descrip = "Exchange Traded Commodity"
        Case "3", "6"
            descrip = "Depository Receipt"
        Case "20", "26"
            descrip = "Real Estate Investment Trust"
        Case "30"
            descrip = "Venture Capital Trust"
        Case "43"
            descrip = "Limited Partnership/LLP"
        End Select
        If descrip <> "" Then GoTo Assign   '<<< changed
        ' Start the section that covers the code C1
        Select Case c1string
        Case "5F"
            descrip = "Structured Product"
        Case "4B"
            descrip = "Equity Link Note"
        Case "41", "42", "43", "44", "45", "46", "47", "48", "49", "4A", "4C", "4D", "4E"
            descrip = "Corporate Debt"
        Case "8A", "8B", "80", "81", "82", "83", "84", "85", "86", "87", "88", "89"
            descrip = "Goverment Debt"
        Case "9A", "9B", "90", "91", "92", "93", "94", "95", "96", "97", "98"
            descrip = "Goverment Debt"
        Case "5G"
            descrip = "Depository Receipt"
        Case "2", "8", "9", "10", "14", "15", "18", "19"
            descrip = "Equity"
        Case "5D", "51", "5A", "5E"
            descrip = "Warrant"
        Case "54"
            descrip = "Composite Unit"
        Case "20", "21", "23", "24", "31", "32", "34", "35"
            descrip = "Preference Share"
        Case "6C"
            descrip = "Mutual Fund"
        Case "6D"
            descrip = "Closed Ended Fund"
        Case "6E"
            descrip = "Other Fund"
        Case "99"
            descrip = "Misc"
        End Select
        If descrip <> "" Then GoTo Assign   '<<< changed
Assign:
        ws.Cells(r, 21) = descrip
        'Platform breakdown
        If Model = "B" Then
            If descrip = "Mutual Fund" Then
                Select Case predpcode
                Case "FND", "PCI", "PIL"
                    descrip2 = "Mutual Fund On Platform"
                Case Else
                    descrip2 = "Mutual Fund Off Platform"
                End Select
            Else
                descrip2 = " "
            End If
        Else
            descrip2 = " "
        End If

        ws.Cells(r, 22) = descrip2
        'this takes up time why not a message when the procedure is completed
        Application.StatusBar = "Progress: " & r & " of maxrows: " & Format(r / maxrows, "0%")
    Next
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.StatusBar = False
End Sub
 
Upvote 0
Hi,

Try this as your first code and see if it not only meet your requirements but that it runs quicker as well. I commented out your description lines so that you could see what you had assigned.

If this works for you, you can apply the same logic to your second code. I am pretty sure it is going to run quicker. Please test on a backup copy of your data...

Code:
Sub Breakdownone()


    Dim vdata As Variant, CAL As Variant
    Dim r As Long, c As Long, maxrows As Long
    Dim range As String, ce17string As String, cs16string As String, c1string As String
    Dim c1char1 As String, vreturndata  As String


    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    ActiveSheet.DisplayPageBreaks = False


    c1char1 = Left(c1string, 1)
    vdata = ActiveSheet.UsedRange.Value


    maxrows = UBound(vdata, 1)
    ReDim CAL(maxrows)
    For r = 3 To maxrows
        c1string = vdata(r, 15)
        ce17string = vdata(r, 16)
        cs16string = vdata(r, 17)
        vreturndata = vdata(r, 20)


    'ce17string column
        Select Case ce17string
            Case "1"
                'descrip = "Hedge Fund"
                CAL(r - 3) = "Hedge Fund"
                GoTo Nrow
        End Select
        
    'ce16string column
        Select Case cs16string
            Case "21", "46", "26"
                'descrip = "Equity"
                CAL(r - 3) = "Equity"
                GoTo Nrow
            Case "17", "44", "31", "45", "54"
                'descrip = "Exchange Traded Fund"
                CAL(r - 3) = "Exchange Traded Fund"
                GoTo Nrow
        End Select


    'c1string column
        Select Case c1string
            Case "2", "8", "9", "5G"
                'descrip = "Equity"
                CAL(r - 3) = "Equity"
                GoTo Nrow
            Case "6D"
                'descrip = "Exchange traded Fund"
                CAL(r - 3) = "Exchange Traded Fund"
                GoTo Nrow
            Case "6C", "6E"
                'descrip = "Fund"
                CAL(r - 3) = "Fund"
                GoTo Nrow
        End Select


    'Begins with c1string column
        Select Case Left(c1string, 1)
            Case "1", "2", "3"
                'descrip = "Equity"
                CAL(r - 3) = "Equity"
            Case "4", "8", "9"
                'descrip = "Debt"
                CAL(r - 3) = "Debt"
            Case "5"
                'descrip = "Derivatives"
                CAL(r - 3) = "Derivatives"
            Case "C"
                'descrip = "Commodities"
                CAL(r - 3) = "Commodities"
        End Select
    
Nrow:
    Next


    Worksheets("Client Asset List").range("T3").Resize(UBound(CAL)) = Application.Transpose(CAL)
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True


End Sub


I hope this helps.

igold
 
Last edited:
Upvote 0
Hi,

In my first post I did not realize that using the Transpose command had limitations on the number of rows (~65000). Therefore I have made the following changes. I tested this on over 100,000 lines of data and the results are significantly faster than your code.

Code:
Sub Breakdownone()


    Dim vdata As Variant, CAL As Variant
    Dim r As Long, c As Long, maxrows As Long
    Dim range As String, ce17string As String, cs16string As String, c1string As String
    Dim c1char1 As String, vreturndata  As String


    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    ActiveSheet.DisplayPageBreaks = False


    c1char1 = Left(c1string, 1)
    vdata = ActiveSheet.UsedRange.Value


    maxrows = UBound(vdata, 1)
    ReDim CAL(maxrows, 0)
    For r = 3 To maxrows
        c1string = vdata(r, 15)
        ce17string = vdata(r, 16)
        cs16string = vdata(r, 17)
        vreturndata = vdata(r, 20)


    'ce17string column
        Select Case ce17string
            Case "1"
                'descrip = "Hedge Fund"
                CAL(r - 3, 0) = "Hedge Fund"
                GoTo Nrow
        End Select
        
    'ce16string column
        Select Case cs16string
            Case "21", "46", "26"
                'descrip = "Equity"
                CAL(r - 3, 0) = "Equity"
                GoTo Nrow
            Case "17", "44", "31", "45", "54"
                'descrip = "Exchange Traded Fund"
                CAL(r - 3, 0) = "Exchange Traded Fund"
                GoTo Nrow
        End Select


    'c1string column
        Select Case c1string
            Case "2", "8", "9", "5G"
                'descrip = "Equity"
                CAL(r - 3, 0) = "Equity"
                GoTo Nrow
            Case "6D"
                'descrip = "Exchange traded Fund"
                CAL(r - 3, 0) = "Exchange Traded Fund"
                GoTo Nrow
            Case "6C", "6E"
                'descrip = "Fund"
                CAL(r - 3, 0) = "Fund"
                GoTo Nrow
        End Select


    'Begins with c1string column
        Select Case Left(c1string, 1)
            Case "1", "2", "3"
                'descrip = "Equity"
                CAL(r - 3, 0) = "Equity"
            Case "4", "8", "9"
                'descrip = "Debt"
                CAL(r - 3, 0) = "Debt"
            Case "5"
                'descrip = "Derivatives"
                CAL(r - 3, 0) = "Derivatives"
            Case "C"
                'descrip = "Commodities"
                CAL(r - 3, 0) = "Commodities"
        End Select
    
Nrow:
    Next
    Worksheets("Client Asset List").range("T3").Resize(UBound(CAL)) = CAL
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True


End Sub

I hope this helps.

igold
 
Upvote 0
Added an output array to your existing code

Code:
Option Explicit '<<< added
Option Base 1 '<<< added
Sub Breakdownone()
    Dim vdata() As Variant
    Dim vdataOut()  '<<< added
    Dim r As Long
    Dim c As Long
    Dim maxrows As Long
    'Dim range As Range  nver use the name range
    Dim ce17string As String
    Dim cs16string As String
    Dim c1string As String
    Dim descrip As String
    Dim c1char1 As String
    Dim vreturndata As String
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    ActiveSheet.DisplayPageBreaks = False
    c1char1 = Left(c1string, 1)
    vdata = ActiveSheet.UsedRange.Value

    maxrows = UBound(vdata, 1)
    ReDim vdataOut(maxrows, 1)    '<<< added array for column T out
    For r = 3 To maxrows
        descrip = ""
        c1string = vdata(r, 15)
        ce17string = vdata(r, 16)
        cs16string = vdata(r, 17)
        vreturndata = vdata(r, 20)
 
        'ce17string column
        Select Case ce17string
        Case "1"
            descrip = "Hedge Fund"
        End Select
        If descrip = "" Then
        Else
            GoTo Assign
        End If
        'ce16string column
        Select Case cs16string
        Case "21", "46", "26"
            descrip = "Equity"
        Case "17", "44", "31", "45", "54"
            descrip = "Exchange Traded Fund"
        End Select
        If descrip = "" Then
        Else
            GoTo Assign
        End If
        'c1string column
        Select Case c1string
        Case "2", "8", "9", "5G"
            descrip = "Equity"
        Case "6D"
            descrip = "Exchange traded Fund"
        Case "6C", "6E"
            descrip = "Fund"
        End Select
        If descrip = "" Then
        Else
            GoTo Assign
        End If
        'Begins with c1string column
        Select Case Left(c1string, 1)
        Case "1", "2", "3"
            descrip = "Equity"
        Case "4", "8", "9"
            descrip = "Debt"
        Case "5"
            descrip = "Derivatives"
        Case "C"
            descrip = "Commodities"
        End Select
        If descrip = "" Then
        Else
            GoTo Assign
        End If
Assign:
        vdataOut(r, 1) = descrip '<<<added
        'Worksheets("Client Asset List").Cells(r, 20) = descrip <<< commneted out
        'Application.StatusBar = "Progress: " & r & " of maxrows: " & Format(r / maxrows, "0%")
    Next
    'be shure to include "Option Base 1" before the sub routine
    Worksheets("Client Asset List").Range("T1:T18").Value = vdataOut   '<<< added
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub


hope this helps</added
 
Last edited:
Upvote 0
Code not complete in prior post

Code:
Option Explicit '<<< added
Option Base 1 '<<< added
Sub Breakdownone()
    Dim vdata() As Variant
    Dim vdataOut()  '<<< added
    Dim r As Long
    Dim c As Long
    Dim maxrows As Long
    'Dim range As Range  nver use the name range
    Dim ce17string As String
    Dim cs16string As String
    Dim c1string As String
    Dim descrip As String
    Dim c1char1 As String
    Dim vreturndata As String
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    ActiveSheet.DisplayPageBreaks = False
    c1char1 = Left(c1string, 1)
    vdata = ActiveSheet.UsedRange.Value

    maxrows = UBound(vdata, 1)
    ReDim vdataOut(maxrows, 1)    '<<< added array for column T out
    For r = 3 To maxrows
        descrip = ""
        c1string = vdata(r, 15)
        ce17string = vdata(r, 16)
        cs16string = vdata(r, 17)
        vreturndata = vdata(r, 20)
 
        'ce17string column
        Select Case ce17string
        Case "1"
            descrip = "Hedge Fund"
        End Select
        If descrip = "" Then
        Else
            GoTo Assign
        End If
        'ce16string column
        Select Case cs16string
        Case "21", "46", "26"
            descrip = "Equity"
        Case "17", "44", "31", "45", "54"
            descrip = "Exchange Traded Fund"
        End Select
        If descrip = "" Then
        Else
            GoTo Assign
        End If
        'c1string column
        Select Case c1string
        Case "2", "8", "9", "5G"
            descrip = "Equity"
        Case "6D"
            descrip = "Exchange traded Fund"
        Case "6C", "6E"
            descrip = "Fund"
        End Select
        If descrip = "" Then
        Else
            GoTo Assign
        End If
        'Begins with c1string column
        Select Case Left(c1string, 1)
        Case "1", "2", "3"
            descrip = "Equity"
        Case "4", "8", "9"
            descrip = "Debt"
        Case "5"
            descrip = "Derivatives"
        Case "C"
            descrip = "Commodities"
        End Select
        If descrip = "" Then
        Else
            GoTo Assign
        End If
Assign:
        vdataOut(r, 1) = descript<added

'Worksheets("Client Asset List").Cells(r, 20) = descrip <<< commneted out
        'Application.StatusBar = "Progress: " & r & " of maxrows: " & Format(r / maxrows, "0%")
    Next
    'be shure to include "Option Base 1" before the sub routine
    Worksheets("Client Asset List").Range("T1:T18").Value = vdataOut   '<<< added
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub
</added
 
Last edited:
Upvote 0

Forum statistics

Threads
1,214,649
Messages
6,120,731
Members
448,987
Latest member
marion_davis

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top