1
\$\begingroup\$

I have code that runs and does what I want it to do with the click of the command button, however when executing, it runs very slow.

The code grabs data from one sheet and inserts/formats it into another sheet in two separate tables that have been converted into range. I did this because I need to automatically update two different graphs with certain data.

I'm still new with VBA coding and any kind of direction or help to make the code run faster is appreciated or ways to remove unnecessary code since it is probably longer than it needs to be.

Public Sub Button1_Click() ' Update Button

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim lastRowPart As Long
Dim lastRowCW As Long
Dim lastRowQty As Long
Dim lastRowQtyLeft As Long
Dim lastRowDescrip As Long
Dim i, j, k As Integer
Dim IO As Worksheet: Set IO = Sheets("Inventory Overview")
Dim TD As Worksheet: Set TD = Sheets("Trend Data")

'1. Copies and formats data

lastRowPart = IO.Cells(Rows.count, "F").End(xlUp).Row
lastRowDescrip = IO.Cells(Rows.count, "G").End(xlUp).Row
lastRowQtyLeft = IO.Cells(Rows.count, "O").End(xlUp).Row
lastRowQty = IO.Cells(Rows.count, "I").End(xlUp).Row
lastRowCW = IO.Cells(Rows.count, "L").End(xlUp).Row

TD.Cells.UnMerge ' reset***

j = 2
k = 2
For i = 2 To lastRowCW
If IO.Cells(i, "L").Value = "Unknown" Then
    TD.Cells(j, "G").Value = IO.Cells(i, "L").Value
    TD.Cells(j, "H").Value = IO.Cells(i, "F").Value
    TD.Cells(j, "I").Value = IO.Cells(i, "I").Value
    TD.Cells(j, "J").Value = IO.Cells(i, "O").Value
    TD.Cells(j, "K").Value = IO.Cells(i, "G").Value
    j = j + 1
Else
    TD.Cells(k, "A").Value = IO.Cells(i, "L").Value
    TD.Cells(k, "B").Value = IO.Cells(i, "F").Value
    TD.Cells(k, "C").Value = IO.Cells(i, "I").Value
    TD.Cells(k, "D").Value = IO.Cells(i, "O").Value
    TD.Cells(k, "E").Value = IO.Cells(i, "G").Value
    k = k + 1
End If
Next

' Autofit
TD.range("B1:B" & lastRowPart).Columns.AutoFit
TD.range("E1:E" & lastRowDescrip).Columns.AutoFit
TD.range("H1:H" & lastRowPart).Columns.AutoFit
TD.range("K1:K" & lastRowDescrip).Columns.AutoFit

'2. Sort Cells
Dim LastRow As Long
LastRow = TD.Cells(Rows.count, 5).End(xlUp).Row

With TD.Sort  ' sorts data from A to Z
 .SetRange TD.range("A2:E" & LastRow)
 .Header = xlGuess
 .MatchCase = False
 .Orientation = xlTopToBottom
 .SortMethod = xlPinYin
 .Apply
End With

'3. Merge CW Cells
' rngMerge = range for parts reworked/left with known CW
' URngMerge = range for parts reported with unknown CW

Dim rngMerge As range, URngMerge As range, cell As range, lastRowMerge As   Long, ULastRowMerge As Long
lastRowMerge = TD.Cells(Rows.count, 1).End(xlUp).Row
ULastRowMerge = TD.Cells(Rows.count, 7).End(xlUp).Row
Set rngMerge = TD.range("A1:A" & lastRowMerge)
Set URngMerge = TD.range("G1:G" & ULastRowMerge)

MergeAgain:
For Each cell In rngMerge
    If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
        range(cell, cell.Offset(1, 0)).Merge
        GoTo MergeAgain
End If
Next

MergeAgain2:
For Each cell In URngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
    range(cell, cell.Offset(1, 0)).Merge
    GoTo MergeAgain2
End If
Next

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub
\$\endgroup\$
2
\$\begingroup\$

Nice job, you dceclared all your variables and your variable names are pretty descriptive. One thing is

Dim i, j, k as Integer

This only has k as Integer, they other two are Variants. You need to type them all:

Dim i as Long, Dim j as Long, Dim k as Long

I went with Long type because integers are obsolete. According to msdn VBA silently converts all integers to long.

One nitpick is Dim LastRow As Long - Standard VBA naming conventions have camelCase for local variables and PascalCase for other variables and names. So lastRow.

You also have rngMerge and UrngMerge - maybe be more descriptive in those names.

Always turn on Option Explicit. You can have it automatically by going to Tools -> Options in the VBE and checking the Require Variable Declaration option. This way if you have any variables not defined, the compiler will let you know.

Worksheets have a CodeName property - View Properties window (F4) and the (Name) field (the one at the top) can be used as the worksheet name. This way you can avoid Sheets("Trend Data") and instead just use TrendData.

I don't know what happened to your formatting, but your indenting isn't showing up as expected. It's good practice to indent all of your code that way Labels will stick out as obvious. You actually have 2 labels that are pretty well hidden.


Speaking of your labels

MergeAgain:
    For Each cell In rngMerge
        If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
            Range(cell, cell.Offset(1, 0)).Merge
            GoTo MergeAgain
        End If
    Next

MergeAgain2:
    For Each cell In URngMerge
        If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
            Range(cell, cell.Offset(1, 0)).Merge
            GoTo MergeAgain2
        End If
    Next

That's a strange way to do this looping.

For j = LastRow To startrow Step -1
    If (.Cells(j, col) = .Cells(j + 1, col)) And Not IsEmpty(.Cells(j, col)) Then .Range(.Cells(j, col), .Cells(j + 1, col)).Merge
Next

No reason to use labels if there's a better way to do it.

You see when you use a boolean function like IsEmpty, you don't need to test its value specifically because the If is looking for True or False already.

Speed

The only way to really gain speed here is to pull your data into arrays and do your operations on those, then spit out entire arrays to the sheet.

I'm not entirely sure of your goal with .Merge but they are your natural enemy. Trust me. It would be better to group the cells and .HorizontalAlignment = xlHAlignCenterAcrossSelection

|improve this answer|||||
\$\endgroup\$
  • \$\begingroup\$ Thank you! I am merging cells because I am trying to auto update two different clustered column graphs. For example, one graph will show a quantity of parts that have been worked on and how many are left to be reworked per calendar week. So the different parts and calendar week will show on the x axis and quantity on the y axis. \$\endgroup\$ – micmc Mar 21 '18 at 13:04
2
\$\begingroup\$

You will get better quality answer if you post example data and/or screenshots or a download link with a sample workbook.

You need a RubberDuck. Download RubberDuck has an code formatting feature that is priceless (and much, much more!!). You should auto-format your code often. It will help you catch end code block mismatches as while as make you code more readable.

j and 'k' are not needed because they will both always equal i.

For i = 2 To lastRowCW
    If IO.Cells(i, "L").Value = "Unknown" Then
        j = j + 1
    Else
        k = k + 1
    End If
Next

Why is '.Header = xlGuess'?

With TD.Sort  ' sorts data from A to Z
   .SetRange TD.Range("A2:E" & LastRow)
   .Header = xlGuess
   .MatchCase = False
   .Orientation = xlTopToBottom
   .SortMethod = xlPinYin
   .Apply
End With

Assuming that the data has headers in .Range("A1:E1") use:

With TD.Sort  ' sorts data from A to Z
   .SetRange TD.Range("A1:E" & LastRow)
   .Header = xlYes

GoTo statement are best reserved for error handling. Although GoTo MergeAgain makes the logic easier to follow it causes you to have to reiterate over the same cells multiple time. In my sample code below I demonstrate how to avoid the it using a range variable.

MergeAgain:
    For Each cell In rngMerge
        If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
            Range(cell, cell.Offset(1, 0)).Merge
            GoTo MergeAgain
        End If
    Next

Application.Calculation = xlCalculationManual could potentially speed up your code.

Reading data from an array instead of directly from the cells will provide a small increase in performance. Writing all the values in a single operation using an array will provide a massive increase in performance.

Avoid naming variables after existing built-in Objects.

At some point while writing your code you had a variable named range that had all lower case letters. I know this because range is improperly capitalized. Adding Dim Range to the top of a code module and then deleting it will fix the capitalization throughout the project.

Consider breaking your code into multiple Subroutines. The fewer tasks that a Subroutines performs the easier it is to write, debug and modify.

There is no advantage to auto-fitting specific ranges.

' Autofit
TD.range("B1:B" & lastRowPart).Columns.AutoFit
TD.range("E1:E" & lastRowDescrip).Columns.AutoFit
TD.range("H1:H" & lastRowPart).Columns.AutoFit
TD.range("K1:K" & lastRowDescrip).Columns.AutoFit

Simple autofit the entire Columns.

TD.Range("B1,E1,H1,K1").EntireColumn.AutoFit

Refactored Code

Public Sub Button1_Click()
    Dim LastRow As Long
    Dim data As Variant
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    With ThisWorkbook.Worksheets("Trend Data")
        TrendDataClear
        data = getInventory
        .Range("A2").Resize(UBound(data, 1), UBound(data, 2)).Value = data
        TrendDataSort
        MergeCells 1, .Cells.Worksheet
        MergeCells "G", .Cells.Worksheet
        .Range("B1,E1,H1,K1").EntireColumn.AutoFit
    End With

    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

Private Function getInventory() As Variant
    Dim i As Long, LastRow As Long
    Dim results As Variant

    With ThisWorkbook.Worksheets("Inventory Overview")
        LastRow = .Cells(Rows.Count, "L").End(xlUp).Row
        ReDim results(1 To LastRow - 1, 1 To 11)

        For i = 2 To LastRow
            If .Cells(i, "L").Value = "Unknown" Then
                results(i - 1, 7) = .Cells(i, "L").Value
                results(i - 1, 8) = .Cells(i, "F").Value
                results(i - 1, 9) = .Cells(i, "I").Value
                results(i - 1, 10) = .Cells(i, "O").Value
                results(i - 1, 11) = .Cells(i, "G").Value
            Else
                results(i - 1, 1) = .Cells(i, "L").Value
                results(i - 1, 2) = .Cells(i, "F").Value
                results(i - 1, 3) = .Cells(i, "I").Value
                results(i - 1, 4) = .Cells(i, "O").Value
                results(i - 1, 5) = .Cells(i, "G").Value
            End If
        Next
    End With

    getInventory = results
End Function

Private Sub MergeCells(vColumn As Variant, ws As Worksheet)
    Dim cell As Range, Target As Range
    With ws
        For Each cell In .Range(.Cells(2, vColumn), .Cells(.Rows.Count, vColumn).End(xlUp))
            If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
                If Target Is Nothing Then
                    Set Target = Range(cell, cell.Offset(1))
                Else
                    Set Target = Range(Target, cell.Offset(1))
                End If
            Else
                If Not Target Is Nothing Then
                    Target.Merge
                    Set Target = Nothing
                End If
            End If
        Next
        If Not Target Is Nothing Then Target.Merge
    End With
End Sub

Private Sub TrendDataClear()
    Dim Target As Range
    With ThisWorkbook.Worksheets("Trend Data")
        Set Target = Intersect(.UsedRange, .UsedRange.Offset(1))
        If Not Target Is Nothing Then
            Target.UnMerge
            Target.ClearContents
        End If
    End With
End Sub

Private Sub TrendDataSort()
    With ThisWorkbook.Worksheets("Trend Data")
        .Sort.SetRange .Range("A1:E1").Resize(Cells(Rows.Count, "L").End(xlUp).Row)
        With .Sort                                    ' sorts data from A to Z
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
End Sub
|improve this answer|||||
\$\endgroup\$
  • \$\begingroup\$ when I ran your code , I got a run time error 1004. It occurred under the TrendDataClear Sub, line: Set Target = Intersect(.UsedRange, .UsedRange.Offset(1)) \$\endgroup\$ – micmc Mar 22 '18 at 19:26
  • \$\begingroup\$ I'm not sure why it would throw an error, unless the UsedRange returning all the rows. Do you have any formats that you want to preserve? Is there a header rows? \$\endgroup\$ – user109261 Mar 22 '18 at 22:19

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for?Browse other questions tagged or ask your own question.