Sorting Poducts VBA Running Slow

[Voltz]

Hello All,

Thanks for the Education you are providing.

I have been using the below code (originally created by Hiker95 in here) for the last 4 years now but now it is getting very slow to sort products, This is used to sort products entered randomly for each order with different products.
Each products consist of 2 rows, Product details and product notes

Time to sort 2K products (4k Rows) = 11 min

Excel File can be downloaded from my shared OneDrive link and it is macro free on xlsx version.

jobsheet 2019.xlsx

1drv.ms

I'm on PC
Window 10
MS Office 365


I appreciate any help getting this running faster.

Thanks.

Sub ReorgData_V6_AS_SENT_BY_HIKER95()
' hiker95, 12/01/2015, ME905348
Dim wjp As Worksheet, wsp As Worksheet
Dim a As Variant, i As Long
Dim o As Variant, j As Long
Dim lr As Long, lc As Long, c As Long, nsc As Long, r As Long
Application.ScreenUpdating = False
Set wjp = Sheets("JSH PRINT")
Set wsp = Sheets("SORTED PRODUCTS")
With wjp
  lr = .Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
  lc = 14
  .Range(.Cells(1, 1), .Cells(lr, lc)).MergeCells = False
  a = .Range(.Cells(1, 1), .Cells(lr, lc))
  ReDim o(1 To UBound(a, 1) / 2, 1 To UBound(a, 2) * 2)
End With
For i = 1 To lr Step 2
  If a(i, 1) = vbEmpty Or a(i, 2) = vbEmpty Then
    'do nothing
  Else
    j = j + 1
    For c = 1 To lc Step 1
      o(j, c) = a(i, c)
    Next c
    nsc = 15
    For c = 1 To lc Step 1
      o(j, nsc) = a(i + 1, c)
      nsc = nsc + 1
    Next c
  End If
Next i
With wsp
  .UsedRange.ClearContents
  .Cells(1, 1).Resize(UBound(o, 1), UBound(o, 2)) = o
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  .Range("A1:AB" & lr).Sort key1:=.Range("B1"), order1:=2
  Erase a: Erase o: j = 0
  a = .Range("A1:AB" & lr)
  lc = 28
  ReDim o(1 To (UBound(a, 1) * 2) + 10, 1 To UBound(a, 2) / 2)
  For i = 1 To lr
    j = j + 1
    For c = 1 To 14 Step 1
      o(j, c) = a(i, c)
    Next c
    j = j + 1
    For c = 15 To lc Step 1
      o(j, c - 14) = a(i, c)
    Next c
  Next i
  .Range("A1:AB" & lr).ClearContents
  .Range("A1").Resize(UBound(o, 1), UBound(o, 2)) = o
  .UsedRange.HorizontalAlignment = xlLeft
  .Activate
End With
Application.ScreenUpdating = True
End Sub

Original data:
Unsorted

Sorted Data:

 

[Fluff]

Yes, see post#9

 

[Voltz]

Excellent. Thanks a million.
Running flowless.

 

[Fluff]

You're welcome & thanks for the feedback