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:

 

[jxb]

maybe start looking at the loops . Very similar loop are defined twice
from

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

to

For i = 1 To lr Step 2
  If a(i, 1) = vbEmpty Or a(i, 2) = vbEmpty Then
    'do nothing
  Else
    j = j + 1
    nsc = 15
    For c = 1 To lc Step 1
      o(j, c) = a(i, c)
      o(j, nsc) = a(i + 1, c)
      nsc = nsc + 1
    Next c
  End If
Next i

 

[Voltz]

Thanks for your reply.

But It didn't change any.

 

[jxb]

That was worth a try. Still the code looks neater
Have you a go at inserting some timer at key position "print" the time to see where you think the bottlenecks are/is ? Is the issue when you start reaching a "large" numbers of row?

 

[Voltz]

Yes it does,?.
No I didn't try timers, I can write a few simple codes but not as this. As in my description this have been done in here by hiker 95 not me, therefore I'm a bit lost on this.

 

[Fluff]

That code takes under a second for me, so there is nothing wrong with the code.
Do you have any event code running?

 

[Voltz]

This is the rest of the whole macro I run

Sub propercase6()
Worksheets("sorted products").Select
Range("A1:L1").Select
Range(Selection, Selection.End(xlDown)).Select
For Each cell In Selection
If Not cell.HasFormula Then
cell.Value = Application.WorksheetFunction.Proper(cell.Value)

End If
Next cell
End Sub
Sub uppercase1()
Worksheets("sorted products").Select
Range("N_COL").Select
For Each cell In Selection
If Not cell.HasFormula Then
cell.Value = UCase(cell.Value)

End If
Next cell
End Sub


Sub Run_Sorting_and_Formatting()
copying
ReorgData_V6
propercase6
uppercase1
    Formating
End Sub

Sub Formating()
    Worksheets("sheet1").Activate
Range("O1:AB2").Select
Selection.Copy
Worksheets("Sorted Products").Activate
Range("A1:N1000").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End Sub

Sub copying()
Worksheets("jsh print").Activate
Selection.Copy
 Worksheets("jsh print1").Activate
Range("a1").Select
ActiveSheet.Paste

End Sub

 

[Voltz]

All the above are in a Macro folder not in sheet events.

Is it normal for an excel file like this to be almost 4mb in size, because I notice that there are other things that also run slow, like if I insert a row it will not happen instantly but it will that a few seconds.

 

[Fluff]

It's going to be the propercase6 sub that's the killer.
Remove that & the uppercase1 sub as well & try

Sub ReorgData_V6()
' 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) = Application.Proper(a(i, c))
      If c = lc Then o(j, c) = UCase(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

 

[Voltz]

You're absolutely correct, it is running 8k rows in about 2 secs.

Is there another way to do the upper and propercase without killing it?