Sorting worksheet by a given column

Question

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

• pacmaninbw: 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?
• TinMan: 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
• FreeMan: 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...
• FreeMan: 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.
• Sᴀᴍ Onᴇᴌᴀ: 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.

Answer 1

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

• Malachi: 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.
• Malachi: 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.
• Kanishk garg: @CDP1802 thanks a lot for this code! It works perfectly.

Answer 2

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.

• TinMan: @CDP1802 Good catch! I removed Option Explicit when I was testing the OP's code.
• Kanishk garg: Thank you so much! This was such a detailed solution and you explained well. Really amazing work!
• Kanishk garg: 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.
• TinMan: @Kanishkgarg I modified the code to handle some edge cases. Let me know if it works for you. CDP1802 's is faster then mine.
• Kanishk garg: 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.