3
\$\begingroup\$

My code runs exactly as it should. However, I would like to make it run a bit faster. I have tried defining some variables as Long to run it faster but it is still a bit slow.

Is it possible to remove some code to make the macro run faster?

Sub sortiereninl()


Dim sort As Worksheet
    Set sort = Worksheets("Inland")

Dim count As Long
Dim n As Long
Dim wkn As Long
    wkn = sort.Cells.Find("WKN").Column
Dim lastcolumn As Long
    lastcolumn = sort.UsedRange.SpecialCells(xlCellTypeLastCell).Column
Dim lastrow As Long
    lastrow = sort.UsedRange.SpecialCells(xlCellTypeLastCell).Row
Dim allrows As Long
    allrows = WorksheetFunction.CountA(Range(Cells(2, wkn), Cells(lastrow, lastcolumn)))



For i = 2 To allrows + 1
    If Cells(i, wkn).Value <> "" Then
        count = sort.Cells(i, Columns.count).End(xlToLeft).Column - wkn
        If count <> 0 Then
            sort.Range(Cells(i + 1, wkn), Cells(i + count, wkn)).EntireRow.Insert
            sort.Range(Cells(i, wkn + 1), Cells(i, count + wkn)).Copy
            sort.Cells(i + 1, wkn).PasteSpecial Transpose:=True
        End If
                
    End If
Next i

With sort.Range(Cells(1, wkn + 1), Cells.SpecialCells(xlCellTypeLastCell))
    .ClearContents
End With

End Sub
\$\endgroup\$
5
  • 2
    \$\begingroup\$ What is the code solving? We can only help you optimize the code when we know what it is doing. Please read How do I ask a good question? \$\endgroup\$
    – pacmaninbw
    Sep 27 '21 at 10:54
  • \$\begingroup\$ Yes, it is possible. Changing the variable to long is not going to improve performance. Here are some tips to help: Top Ten Tips To Speed Up Your VBA Code \$\endgroup\$
    – TinMan
    Sep 27 '21 at 11:01
  • \$\begingroup\$ I will say that a variable named sort will throw people off. I presume it means something in your language that's different from what it means in English, remember, though that Range.Sort is the same in VBA no matter what spoken language you use. I'm only on my 1st cup of coffee, but I saw all those lines beginning sort.Range(... and though you were sorting your data in a loop which would be slow... \$\endgroup\$
    – FreeMan
    Sep 27 '21 at 11:35
  • 1
    \$\begingroup\$ Your best bet would probably be to copy the data from the worksheet to Dim sourceData() as Variant, copy/transpose it to Dim destData() as Variant, then past destData() back to the worksheet. Reading/writing to the worksheet is going to be the slowest operation you're doing in that loop, though I'm not sure where PasteSpecial.Transpose falls in the "speed" range. There are plenty of answers here and at StackOverflow on how to copy a range from a worksheet to an array and back. \$\endgroup\$
    – FreeMan
    Sep 27 '21 at 11:45
  • \$\begingroup\$ Welcome to Code Review! I changed the title so that it describes what the code does per site goals: "State what your code does in your title, not your main concerns about it.". Feel free to edit and give it a different title if there is something more appropriate. \$\endgroup\$ Sep 27 '21 at 18:11
0
\$\begingroup\$

It is faster to read the data from the Sheet into an array, process the array values into a new array, then write the new array back to the sheet.

Sub sortierenin2()

    Dim sort As Worksheet
    Dim count As Long, i As Long, n As Long, newrows As Long
    Dim WKN As Long, lastcolumn As Long, lastrow As Long
    Dim arIn, arOut, iOut As Long, j As Long, t0 As Single: t0 = Timer

    Set sort = Worksheets("Inland")
    With sort
        WKN = .Cells.Find("WKN").Column
        lastcolumn = .UsedRange.SpecialCells(xlCellTypeLastCell).Column
        lastrow = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
        newrows = WorksheetFunction.CountA(.Range(.Cells(2, WKN + 1), .Cells(lastrow, lastcolumn)))
        ' Copy from sheet into array
        arIn = .UsedRange
    End With
    ' Size array to take existing rows and new rows
    ReDim arOut(1 To UBound(arIn) + newrows, 1 To WKN)
    For i = 1 To UBound(arIn)
        iOut = iOut + 1
        For j = 1 To lastcolumn
            If j > WKN Then
                ' Insert a new row for every column after WKN
                If (i > 1) And (arIn(i, j) <> "") Then
                    iOut = iOut + 1
                    arOut(iOut, WKN) = arIn(i, j)
                End If
            Else
                ' Copy existing row
                arOut(iOut, j) = arIn(i, j)
            End If
        Next
    Next
   
    ' Write array with inserted rows back to sheet.
    Application.ScreenUpdating = False
    With sort
        .UsedRange.ClearContents
        .Range("A1").Resize(UBound(arOut), UBound(arOut, 2)) = arOut
    End With
    Application.ScreenUpdating = True

    MsgBox Format(Timer - t0, "0.00 secs")
      
End Sub
\$\endgroup\$
3
  • 2
    \$\begingroup\$ You have presented an alternative solution, but haven't reviewed the code. Please explain your reasoning (how your solution works and why it is better than the original) so that the author and other readers can learn from your thought process. \$\endgroup\$
    – Malachi
    Sep 27 '21 at 14:23
  • 2
    \$\begingroup\$ We Appreciate the added bit about the reason for using Arrays, but could you add more explanation around the steps that you took to convert the OP Code to your Code with the Arrays? it would help the OP understand how to write better code. \$\endgroup\$
    – Malachi
    Sep 27 '21 at 17:22
  • \$\begingroup\$ @CDP1802 thanks a lot for this code! It works perfectly. \$\endgroup\$ Sep 29 '21 at 9:25
4
\$\begingroup\$

Turn Off ScreenUpdating and Calculations to Optimize Performance

This stops VBA from having to want for Excel to recalculate formulas and refresh the screen.

Turn Off ScreenUpdating and Calculations:

With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
End With

Restore ScreenUpdating and Calculations:

With Application
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = False
End With

Option Explicit

Adding Option Explicit to the top of the Modules forces us to declarer our variables. This prevents use from testing code that has typos.

Ranges Should be Fully Qualified

Ranges should be "fully qualified" to their Worksheet. This ensures that you code is processing the cells on the correct worksheet.

Set sort = Worksheets("Inland")
With sort.Range(Cells(1, wkn + 1), Cells.SpecialCells(xlCellTypeLastCell))
    .ClearContents
End With

Sort is qualified to the Inland worksheet. Cells(1, wkn + 1) references the ActiveSheet. The code will throw an error if Inland is not the active worksheet.

The code below is fully qualified. It will run as expected as long as the Workbook is the active Workbook.

With Worksheets("Inland")
    With sort.Range(.Cells(1, wkn + 1), .Cells.SpecialCells(xlCellTypeLastCell))
        .ClearContents
    End With
End With

When working with multiple workbooks, Ranges should be fully qualified to their workbook like this:

With ThisWorkbook.Worksheets("Inland")
    With sort.Range(.Cells(1, wkn + 1), .Cells.SpecialCells(xlCellTypeLastCell))
        .ClearContents
    End With
End With

Variable Naming

Variables should have clear unambiguous names. Ideally, our code should make sense when spoken.

Use Range.CurrentRegion when Applicable

Here is my fallback order for setting up data in excel

  1. Tables: the ideal way to reference data in Excel
  2. Lists: a contiguous block of related cells. The block of code may have a header row but no completely empty rows and no extra rows that have nothing to do with you target data.

Setting your data up like this will make it easy to reference your ranges.

In the following examples we have a list that starts in the first cell on the Inland tab.

Example 1: Header and Data Rows

With Worksheets("Inland")
   Set Target = .Range("A1").CurrentRegion
End With

Example 2: Only Header Row

With Worksheets("Inland")
   Set Target = .Range("A1").CurrentRegion.Rows(1)
End With

Example 3: Only Header Row

With Worksheets("Inland")
   Set target = .Range("A1").CurrentRegion
   Set target = Intersect(target, target.Offset(1))
End With

Refactored Code

The fun part of the review!

Notice that I clearly define all ranges that I will be working with. While writing the code I use Range.Select to ensure the correct range is getting targeted.

Sub RefactoredSortiereninl()


    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = False
    End With
    
    With Worksheets("Inland")
        Dim DataRange As Range
        Set DataRange = .Range("A1").CurrentRegion
       
        Dim DataBodyRange As Range
        Set DataBodyRange = Intersect(DataRange, DataRange.Offset(1))
       
        Dim WKNColumn As Range
        Set WKNColumn = Intersect(DataRange, DataRange.Rows(1).Find("WKN").EntireColumn)
        
        Dim DataColumns As Range
        Rem The next line was originally posted but would return extra columns if WKNColumn was the last column
        Rem Set DataColumns = WKNColumn.Resize(, WKNColumn.End(xlToRight).Column - WKNColumn.Column + 1)
        Set DataColumns = WKNColumn.Resize(, .Columns(.Columns.count).End(xlToLeft).Column - WKNColumn.Column + 1)
        Dim WKN As Long
        WKN = WKNColumn.Column
       
        Dim NewLastRow As Long
        NewLastRow = WorksheetFunction.CountA(DataColumns) + 1
        
        Dim r As Long, count As Long
        For r = 2 To NewLastRow
            If .Cells(r, WKN).Value <> "" Then
                count = .Cells(r, .Columns.count).End(xlToLeft).Column - WKN
                If count <> 0 Then
                    .Range(.Cells(r + 1, WKN), .Cells(r + count, WKN)).EntireRow.Insert
                    .Range(.Cells(r, WKN + 1), .Cells(r, count + WKN)).Copy
                    .Cells(r + 1, WKN).PasteSpecial Transpose:=True
                End If
            End If
        Next r
        
      Rem Rem The next line was originally posted but would fail if DataColumns last column was the last column in the Worksheet
      Rem DataColumns.Offset(, 1).ClearContents
      DataColumns.Resize(, DataColumns.Columns.count - 1).Offset(, 1).ClearContents
      
    End With
    
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    
End Sub

Optimal Performance

Performing all work in memory using arrays will give you the optimal performance. Here are the steps:

  1. Read the data into an array
  2. Declare a second array to hold the results
  3. Size the results array to fit the new data
  4. Assign the old values to the results array
  5. Clear the old data
  6. Write the new data to the worksheet

I find that this technique is able to process ~60,000 values per second.

\$\endgroup\$
7
  • \$\begingroup\$ @CDP1802 Good catch! I removed Option Explicit when I was testing the OP's code. \$\endgroup\$
    – TinMan
    Sep 27 '21 at 14:09
  • \$\begingroup\$ Thank you so much! This was such a detailed solution and you explained well. Really amazing work! \$\endgroup\$ Sep 28 '21 at 7:55
  • \$\begingroup\$ I am just getting one error with the refactored code on the line - DataColumns.Offset(, 1).ClearContents . The error reads as Application-defined or object-defined error. \$\endgroup\$ Sep 28 '21 at 8:26
  • \$\begingroup\$ @Kanishkgarg I modified the code to handle some edge cases. Let me know if it works for you. CDP1802 's is faster then mine. \$\endgroup\$
    – TinMan
    Sep 28 '21 at 16:50
  • \$\begingroup\$ Hey, I am still getting the same error for the line - DataColumns.Resize(, DataColumns.Columns.count - 1).Offset(, 1).ClearContents. I think your comment about Datacolumns being the last column holds true. \$\endgroup\$ Sep 29 '21 at 8:50

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.