trjhtr

I made a macro that will fill in data in a workbook that has 65 (24 are user filled) columns and can go as long as 1500 rows.

In an ideal scenario, the workbook has a perfect column that could work as a key to fill in the data. The thing is, users can duplicate a row, therefore messing with the column with unique values (the duplicates are needed).

So, I went and made a collection of classes.

1. I test if there are duplicates in the key columns in the old WB(the one with data to import into the new WB) (called Orders from now on) and I count how many.


2. For each row in the old workbook (the one I want to pull information from) I create a class, fill in the variables, and add it to a collection.


3. In the new workbook, I call the collection that has the duplicates count and I create new rows for each order that has a duplicate (more than 2 is possible).


4. I iterate through the classes that have the information from the old workbook. When a match is found, using the order column in the new workbook, I call in the class and go about getting the values its variables have.

This method worked perfectly for a good while until recently when we started seeing workbooks with more and more data. Now, for a workbook with more than 1500 rows and 24 columns full of information my code is taking close to an hour to fill a new workbook with that much data.

Sub GetDataFromWB()


Call pw

Dim fileName As Variant
Dim oldOrders As Workbook
Dim newOrders As Workbook
Dim oldOrdersTable As ListObject
Dim newOrdersTable As ListObject
Dim rRows As Integer
Dim Ord As CPurchaseOrder
Dim OrdersInfo As Collection
Dim countOrd As Collection
Dim dataItems As cItems
Dim itemKey As String
Dim newWS As Worksheet
Dim oldWS As Worksheet
Dim testOrd As String
Dim wbCount As Integer
Dim i As Integer
Dim keyCells As Range
Dim cel As Range
Dim rowCount As Integer

Dim StartTime As Double
Dim MinutesElapsed As String

If Workbooks.Count > 1 Then
 wbCount = PromptForWorkbook()
 If wbCount = 0 Then Exit Sub
 Set newOrders = Workbooks(wbCount)
Else
 Set newOrders = ActiveWorkbook
End If

'Remember time when macro starts
 StartTime = Timer

Set newWS = newOrders.Worksheets("Orders")

Set OrdersInfo = New Collection
Set countOrd = New Collection

fileName = Application.GetOpenFilename("Excel files (*.xls*), *.xls*", 1, "Select a Orders Workbook")
If fileName = False Then Exit Sub

Set oldOrders = Workbooks.Open(fileName)
Set oldWS = oldOrders.Worksheets("Orders")

Set newOrdersTable = newOrders.Worksheets("Orders").ListObjects("TableOrdersQuery")
Set oldOrdersTable = oldOrders.Worksheets("Orders").ListObjects("TableOrdersQuery")



'Adds all information in old Orders to a collection and counts how many times a OrdLINE repeats itself (splits)
rowCount = oldOrdersTable.ListRows.Count + 1
For rRows = 2 To oldOrdersTable.ListRows.Count + 1
 On Error Resume Next

 'The workbook has a COMMENT column which concatenate important info, to avoid going through all rows, the column must have information to be pulled in the new wb
 If Len(oldWS.Cells(rRows, 64)) > 6 Then

 'Counts duplicate values in old Orders
 itemKey = CStr(oldOrders.Worksheets("Orders").Cells(rRows, 8).Value)

 Set dataItems = Nothing: On Error Resume Next
 Set dataItems = countOrd(itemKey): On Error GoTo 0

 If dataItems Is Nothing Then
 Set dataItems = New cItems
 dataItems.Key = itemKey
 countOrd.Add dataItems, itemKey
 End If

 With dataItems
 .Count = .Count + 1
 End With


 '------OLD Orders INFO------'
 On Error Resume Next
 Set Ord = New CPurchaseOrder
 Ord.OrdLine = oldOrders.Worksheets("Orders").Cells(rRows, 8).Value

 Ord.LabDipStatus = oldOrders.Worksheets("Orders").Cells(rRows, 32).Value
 Ord.LabDipDate = oldOrders.Worksheets("Orders").Cells(rRows, 33).Value
 Ord.ReasonDelayLapDip = oldOrders.Worksheets("Orders").Cells(rRows, 34).Value
 Ord.OtherReasonDelayLabDip = oldOrders.Worksheets("Orders").Cells(rRows, 35).Value
 Ord.SubmitLabDip = oldOrders.Worksheets("Orders").Cells(rRows, 36).Value
 Ord.TrackingLabDip = oldOrders.Worksheets("Orders").Cells(rRows, 37).Value

 Ord.ProdLotStatus = oldOrders.Worksheets("Orders").Cells(rRows, 38).Value
 Ord.ProdLotDate = oldOrders.Worksheets("Orders").Cells(rRows, 39).Value
 Ord.ReasonDelayProdLot = oldOrders.Worksheets("Orders").Cells(rRows, 40).Value
 Ord.OtherReasonDelayProdLot = oldOrders.Worksheets("Orders").Cells(rRows, 41).Value
 Ord.SubmitProdLot = oldOrders.Worksheets("Orders").Cells(rRows, 42).Value
 Ord.TrackingProdLot = oldOrders.Worksheets("Orders").Cells(rRows, 43).Value

 Ord.ShipFrom = oldOrders.Worksheets("Orders").Cells(rRows, 44).Value
 'Ord.OrderShipment = oldOrders.Worksheets("Orders").Cells(rRows, 45).Value
 Ord.OrdrderStatus = oldOrders.Worksheets("Orders").Cells(rRows, 46).Value
 Ord.WorkProgress = oldOrders.Worksheets("Orders").Cells(rRows, 47).Value
 Ord.OrdDeliveryDate = oldOrders.Worksheets("Orders").Cells(rRows, 48).Value
 Ord.RealQtyShipped = oldOrders.Worksheets("Orders").Cells(rRows, 50).Value
 Ord.ShipMode = oldOrders.Worksheets("Orders").Cells(rRows, 53).Value
 Ord.Container = oldOrders.Worksheets("Orders").Cells(rRows, 54).Value
 Ord.Invoice = oldOrders.Worksheets("Orders").Cells(rRows, 55).Value
 Ord.ReasonChange = oldOrders.Worksheets("Orders").Cells(rRows, 58).Value
 Ord.OtherReasonChange = oldOrders.Worksheets("Orders").Cells(rRows, 59).Value
 Ord.NewOrdDeliveryDate = oldOrders.Worksheets("Orders").Cells(rRows, 60).Value
 Ord.Comments = oldOrders.Worksheets("Orders").Cells(rRows, 64).Value

 OrdersInfo.Add Ord
 End If
Next rRows


For Each cel In newOrdersTable.ListColumns("Ord/LINE").DataBodyRange
 itemKey = CStr(cel.Value)
 Set dataItems = Nothing: On Error Resume Next
 Set dataItems = countOrd(itemKey): On Error GoTo 0

 If dataItems Is Nothing Then

 Else
 If dataItems.Count > 1 Then
 newWS.Unprotect Password
 Set keyCells = Intersect(cel.EntireRow, newOrdersTable.DataBodyRange)

 'THIS MACRO INSERTS ROW IN THE TABLE BASED IN THE COUNT OF DUPLICATES OF EACH Ord/LINE
 Call InsertRows(dataItems.Count - 1, keyCells)
 countOrd.Remove itemKey
 End If
 End If
Next cel

'Deletes validations because they mess everything up
newWS.Cells.Validation.Delete

rowCount = newOrdersTable.ListRows.Count + 1
For rRows = 2 To rowCount
 'Starts importing stuff.
 For i = OrdersInfo.Count To 1 Step -1
 Set Ord = OrdersInfo(i)
 If newOrders.Worksheets("Orders").Cells(rRows, 8) = Ord.OrdLine Then
 Application.EnableEvents = False
 Application.ScreenUpdating = False
 'LAB DIP
 newOrders.Worksheets("Orders").Cells(rRows, 32) = Ord.LabDipStatus
 newOrders.Worksheets("Orders").Cells(rRows, 33) = Ord.LabDipDate
 newOrders.Worksheets("Orders").Cells(rRows, 34) = Ord.ReasonDelayLapDip
 newOrders.Worksheets("Orders").Cells(rRows, 35) = Ord.OtherReasonDelayLabDip
 newOrders.Worksheets("Orders").Cells(rRows, 36) = Ord.SubmitLabDip
 newOrders.Worksheets("Orders").Cells(rRows, 37) = Ord.TrackingLabDip

 'PROD LOT
 newOrders.Worksheets("Orders").Cells(rRows, 38) = Ord.ProdLotStatus
 newOrders.Worksheets("Orders").Cells(rRows, 39) = Ord.ProdLotDate
 newOrders.Worksheets("Orders").Cells(rRows, 40) = Ord.ReasonDelayProdLot
 newOrders.Worksheets("Orders").Cells(rRows, 41) = Ord.OtherReasonDelayProdLot
 newOrders.Worksheets("Orders").Cells(rRows, 42) = Ord.SubmitProdLot
 newOrders.Worksheets("Orders").Cells(rRows, 43) = Ord.TrackingProdLot

 'Ord STATUS
 newOrders.Worksheets("Orders").Cells(rRows, 44) = Ord.ShipFrom
 newOrders.Worksheets("Orders").Cells(rRows, 45) = Ord.OrderShipment
 newOrders.Worksheets("Orders").Cells(rRows, 47) = Ord.OrdrderStatus
 newOrders.Worksheets("Orders").Cells(rRows, 48) = Ord.WorkProgress
 newOrders.Worksheets("Orders").Cells(rRows, 49) = Ord.OrdDeliveryDate
 newOrders.Worksheets("Orders").Cells(rRows, 50) = Ord.RealQtyShipped
 newOrders.Worksheets("Orders").Cells(rRows, 53) = Ord.ShipMode
 newOrders.Worksheets("Orders").Cells(rRows, 54) = Ord.Container
 newOrders.Worksheets("Orders").Cells(rRows, 55) = Ord.Invoice
 newOrders.Worksheets("Orders").Cells(rRows, 58) = Ord.ReasonChange
 newOrders.Worksheets("Orders").Cells(rRows, 59) = Ord.OtherReasonChange
 newOrders.Worksheets("Orders").Cells(rRows, 60) = Ord.NewOrdDeliveryDate
 'newOrders.Worksheets("Orders").Cells(rRows, 64) = Ord.Comments
 Application.EnableEvents = True
 Application.ScreenUpdating = True
 OrdersInfo.Remove i
 Exit For
 End If
 Next i
Next rRows

newWS.Unprotect Password

Set keyCells = newOrdersTable.ListColumns("Lab dip status").DataBodyRange
Call DoValidation("Wrong value", 3, "=INDIRECT(""TableLabProdStatus[LabProdStatus]"")", keyCells, "Choose a value from drop down list")

Set keyCells = newOrdersTable.ListColumns("Prod Lot Status").DataBodyRange
Call DoValidation("Wrong value", 3, "=INDIRECT(""TableLabProdStatus[LabProdStatus]"")", keyCells, "Choose a value from drop down list") 

Set keyCells = newOrdersTable.ListColumns("Reason for delay (Lab dip)").DataBodyRange
Call DoValidation("Wrong value", 3, "=INDIRECT(""TableLabDipReasons[LabDipReasons]"")", keyCells, "Choose a value from drop down list")

Set keyCells = newOrdersTable.ListColumns("Reason for delay (Prod Lot)").DataBodyRange
Call DoValidation("Wrong value", 3, "=INDIRECT(""TableProdLotReasons[ProdLotReasons]"")", keyCells, "Choose a value from drop down list")

Set keyCells = newOrdersTable.ListColumns("Ord Status").DataBodyRange
Call DoValidation("Wrong value", 3, "=INDIRECT(""TableOrdStatus[OrdStatus]"")", keyCells, "Choose a value from drop down list")

Set keyCells = newOrdersTable.ListColumns("Ship from").DataBodyRange
Call DoValidation("Wrong value", 3, "=INDIRECT(""TableShipFrom[ShipFrom]"")", keyCells, "Choose a value from drop down list")

Set keyCells = newOrdersTable.ListColumns("Order Shipment").DataBodyRange
Call DoValidation("Wrong value", 3, "=INDIRECT(""TableOrderShipment[OrderShipment]"")", keyCells, "Choose a value from drop down list")

Set keyCells = newOrdersTable.ListColumns("SHIPMODE").DataBodyRange
Call DoValidation("Wrong value", 3, "=INDIRECT(""TableShipMode[ShipMode]"")", keyCells, "Choose a value from drop down list")

Set keyCells = newOrdersTable.ListColumns("REASON FOR CHANGE").DataBodyRange
Call DoValidation("Wrong value", 3, "=INDIRECT(""TableReasonChange[ReasonChange]"")", keyCells, "Choose a value from drop down list")


'Determine how many seconds code took to run
MinutesElapsed = format((Timer - StartTime) / 86400, "hh:mm:ss")

'Notify user in seconds
MsgBox "This code ran successfully in " & MinutesElapsed & " seconds." & vbNewLine & "The amount of rows read from the old Orders workbook are: " & oldOrdersTable.ListRows.Count & "." & vbNewLine & "The amount of rows read in new Orders are: " & newOrdersTable.ListRows.Count & ".", vbInformation

ExitHandler:
 Application.EnableEvents = True
 newWS.Protect Password:=Password, DrawingObjects:=True, Contents:=True, Scenarios:=False _
, AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True, AllowFormattingRows:=True, AllowFormattingColumns:=True, AllowFormattingCells:=True


End Sub

CPurchaseOrder Class

Option Compare Text 

Private pOrdLine As String
Private pLabDipStatus As String
Private pLabDipDate As String
Private pReasonDelayLapDip As String
Private pOtherReasonDelayLabDip As String
Private pSubmitLabDip As String
Private pTrackingLabDip As String
Private pProdLotStatus As String
Private pProdLotDate As String
Private pReasonDelayProdLot As String
Private pOtherReasonDelayProdLot As String
Private pSubmitProdLot As String
Private pTrackingProdLot As String
Private pShipFrom As String
Private pOrderShipment As String
Private pOrdrderStatus As String
Private pWorkProgress As String
Private pOrdDeliveryDate As String
Private pRealQtyShipped As Long
Private pShipMode As String
Private pContainer As String
Private pInvoice As String
Private pReasonChange As String
Private pOtherReasonChange As String
Private pNewOrdDeliveryDate As String
Private pComments As String

Public Property Get OrdLine() As String
 OrdLine = pOrdLine
End Property
Public Property Let OrdLine(Value As String)
 pOrdLine = Value
End Property
'---------------LAB DIP-------------------
'-----------------------------------------
Public Property Get LabDipStatus() As String
 LabDipStatus = pLabDipStatus
End Property
Public Property Let LabDipStatus(Value As String)
 pLabDipStatus = Value
End Property
Public Property Get LabDipDate() As String
 LabDipDate = pLabDipDate
End Property
Public Property Let LabDipDate(Value As String)
 pLabDipDate = Value
End Property
Public Property Get ReasonDelayLapDip() As String
 ReasonDelayLapDip = pReasonDelayLapDip
End Property
Public Property Let ReasonDelayLapDip(Value As String)
 pReasonDelayLapDip = Value
End Property
Public Property Get OtherReasonDelayLabDip() As String
 OtherReasonDelayLabDip = pOtherReasonDelayLabDip
End Property
Public Property Let OtherReasonDelayLabDip(Value As String)
 pOtherReasonDelayLabDip = Value
End Property
Public Property Get SubmitLabDip() As String
 SubmitLabDip = pSubmitLabDip
End Property
Public Property Let SubmitLabDip(Value As String)
 pSubmitLabDip = Value
End Property
Public Property Get TrackingLabDip() As String
 TrackingLabDip = pTrackingLabDip
End Property
Public Property Let TrackingLabDip(Value As String)
 pTrackingLabDip = Value
End Property
'---------------PROD LOT------------------
'-----------------------------------------
Public Property Get ProdLotStatus() As String
 ProdLotStatus = pProdLotStatus
End Property
Public Property Let ProdLotStatus(Value As String)
 pProdLotStatus = Value
End Property
Public Property Get ProdLotDate() As String
 ProdLotDate = pProdLotDate
End Property
Public Property Let ProdLotDate(Value As String)
 pProdLotDate = Value
End Property
Public Property Get ReasonDelayProdLot() As String
 ReasonDelayProdLot = pReasonDelayProdLot
End Property
Public Property Let ReasonDelayProdLot(Value As String)
 pReasonDelayProdLot = Value
End Property
Public Property Get OtherReasonDelayProdLot() As String
 OtherReasonDelayProdLot = pOtherReasonDelayProdLot
End Property
Public Property Let OtherReasonDelayProdLot(Value As String)
 pOtherReasonDelayProdLot = Value
End Property
Public Property Get SubmitProdLot() As String
 SubmitProdLot = pSubmitProdLot
End Property
Public Property Let SubmitProdLot(Value As String)
 pSubmitProdLot = Value
End Property
Public Property Get TrackingProdLot() As String
 TrackingProdLot = pTrackingProdLot
End Property
Public Property Let TrackingProdLot(Value As String)
 pTrackingProdLot = Value
End Property
'---------------ORD STATUS-----------------
'-----------------------------------------
Public Property Get ShipFrom() As String
 ShipFrom = pShipFrom
End Property
Public Property Let ShipFrom(Value As String)
 pShipFrom = Value
End Property
Public Property Get OrderShipment() As String
 OrderShipment = pOrderShipment
End Property
Public Property Let OrderShipment(Value As String)
 pOrderShipment = Value
End Property
Public Property Get OrdrderStatus() As String
 OrdrderStatus = pOrdrderStatus
End Property
Public Property Let OrdrderStatus(Value As String)
 If Value = "Shipping" Then Value = "In Progress"
 pOrdrderStatus = Value
End Property
Public Property Get WorkProgress() As String
 WorkProgress = pWorkProgress
End Property
Public Property Let WorkProgress(Value As String)
 pWorkProgress = Value
End Property
Public Property Get OrdDeliveryDate() As String
 OrdDeliveryDate = pOrdDeliveryDate
End Property
Public Property Let OrdDeliveryDate(Value As String)
 pOrdDeliveryDate = Value
End Property
Public Property Get RealQtyShipped() As Long
 RealQtyShipped = pRealQtyShipped
End Property
Public Property Let RealQtyShipped(Value As Long)
 pRealQtyShipped = Value
End Property
Public Property Get ShipMode() As String
 ShipMode = pShipMode
End Property
Public Property Let ShipMode(Value As String)
 Select Case Value
 Case "By Air (any carrier)"
 Value = "Air (any carrier)"
 Case "By Land"
 Value = "Land"
 Case "By Sea"
 Value = "Sea"
 Case "By ASAP"
 Value = "Expediting (ASAP)"
 Case Else

 End Select
 pShipMode = Value
End Property
Public Property Get Container() As String
 Container = pContainer
End Property
Public Property Let Container(Value As String)
 pContainer = Value
End Property
Public Property Get Invoice() As String
 Invoice = pInvoice
End Property
Public Property Let Invoice(Value As String)
 pInvoice = Value
End Property
'---------------DLVRY CHANGE--------------
'-----------------------------------------
Public Property Get ReasonChange() As String
 ReasonChange = pReasonChange
End Property
Public Property Let ReasonChange(Value As String)
 pReasonChange = Value
End Property
Public Property Get OtherReasonChange() As String
 OtherReasonChange = pOtherReasonChange
End Property
Public Property Let OtherReasonChange(Value As String)
 pOtherReasonChange = Value
End Property
Public Property Get NewOrdDeliveryDate() As String
 NewOrdDeliveryDate = pNewOrdDeliveryDate
End Property
Public Property Let NewOrdDeliveryDate(Value As String)
 pNewOrdDeliveryDate = Value
End Property

Public Property Get Comments() As String
 Comments = pComments
End Property
Public Property Let Comments(Value As String)
 If Err.Number <> 0 Then Resume Next
 pComments = Value
End Property

CItems Class

Public Key As String
Public Count As Long
Public ItemList As Collection

Private Sub Class_Initialize()
 Count = 0
 Set ItemList = New Collection
End Sub

Insert Rows Sub

Public Sub InsertRows(splitVal As Integer, keyCells As Range)

Call pw

Dim ws As Worksheet
Dim wb As Workbook

Set wb = ThisWorkbook
Set ws = wb.Worksheets("Orders")

ws.Unprotect Password

Application.EnableEvents = False
With keyCells
 On Error GoTo ErrorHandler
 'When filtered, can't paste and insert, so two steps
 .Offset(1).Resize(splitVal).EntireRow.Insert
 .EntireRow.Copy .Offset(1, 0).Resize(splitVal).EntireRow
End With

ExitHandler:
 Call PerformanceDown
 wb.Worksheets("Orders").Protect Password:=Password, DrawingObjects:=True, Contents:=True, Scenarios:=False _
 , AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True, AllowFormattingRows:=True, AllowFormattingColumns:=True, AllowFormattingCells:=True
Exit Sub

ErrorHandler:
 MsgBox Err.Number & ": " & Err.Description, vbOKOnly
 GoTo ExitHandler

End Sub

PromptForWorkbook

Function PromptForWorkbook() As Integer
Dim n As Long
Dim S As String
Dim wb As Workbook


StartOver:
n = 0
S = vbNullString

For Each wb In Workbooks
 n = n + 1
 S = S & CStr(n) & " - " & wb.Name & vbNewLine
Next wb

If Len(S) > 196 Then
 MsgBox "Please close 1 workbook and try again. The inputbox character limit is 255 and the open workbooks combined exceeds that limit"
 Exit Function
End If

n = Application.InputBox(prompt:="Choose the new Order WB to which you want to import information." & vbNewLine & S, Type:=1)

If n <= 0 Or n > Workbooks.Count Then
 PromptForWorkbook = 0
Else

 If InStr(Workbooks(n).Name, "ORDER") = 0 Then
 resp = MsgBox("Are you sure this workbook is a valid ORDER WB?", vbYesNo, "Only ORDER Workbooks acceptable")
 If resp = vbNo Then
 GoTo StartOver
 End If
 End If

 PromptForWorkbook = n
End If

End Function

DoValidation

Public Sub DoValidation(errorTitle As String, valType As Long, valForm As String, rng As Range, errorMsg As String)

With rng.Validation
 .Delete
 .Add Type:=valType, AlertStyle:=xlValidAlertStop, Operator:= _
 xlBetween, Formula1:=valForm
 .IgnoreBlank = True
 .InCellDropdown = True
 .InputTitle = ""
 .errorTitle = errorTitle
 .InputMessage = ""
 .ErrorMessage = errorMsg
 .ShowInput = True
 .ShowError = True
End With

End Sub

Performancedown and up

Sub PerformanceUp()
 With Application
 .EnableEvents = False
 .ScreenUpdating = False
 End With
End Sub

Sub PerformanceDown()
 With Application
 .EnableEvents = True
 .ScreenUpdating = True
 End With
End Sub

The PW call just calls in a global variable that holds a password.

First, just some simple observations.

• It's good practice to indent all of your code that way Labels will stick out as obvious.




• You don't need to Call subs, it's obsolete. Instead just use Sub argument, argument




• Comments - "code tell you how, comments tell you why". The code should speak for itself, if it needs a comment, it might need to be made more clear. If not, the comment should describe why you're doing something rather than how you're doing it. Here are a few reasons to avoid comments all together.




• If fileName = False Then Exit Sub can be rewritten to If Not fileName Then Exit Sub, but that would be assuming it's boolean, which it isn't. Unfortunately the ms documentation gives the example using False so I can't have an issue with that.




• Integers - integers are obsolete. According to msdn VBA silently converts all integers to long.




• Standard VBA naming conventions have camelCase for local variables and PascalCase for other variables and names.




• 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("mySheet") and instead just use mySheet.




• Sub and Function parameters are implicitly passed ByRef if you don't specify. Try to pass them ByVal whenever possible.

This part here can look simpler -

Set newOrdersTable = newOrders.Worksheets("Orders").ListObjects("TableOrdersQuery")
Set oldOrdersTable = oldOrders.Worksheets("Orders").ListObjects("TableOrdersQuery")

You already have newWS and oldWS, so just use those variables. On the other hand, you don't have any error handling here, what if the table doesn't exist or the name is different? Maybe a better approach would be

Function gettable(ByVal targetSheet As Worksheet) As ListObject
 With targetSheet
 For i = 1 To .ListObjects.Count
 If .ListObjects.Item(i).Name = "TableOrdersQuery" Then
 Set gettable = .ListObjects.Item(i)
 Exit Function
 End If
 Next
 End With
End Function

Or more likely just put in some error handling. Sometimes it's better to break things out like that for clarity.

I think you've done a good job of implementing CPurchaseOrder for what you need (Object-Oriented!).

However, I'm not sure why cItems is just a Collection - that's an object inside a custom object, no other properties. Seems unnecessary. I'd say use a Dictionary:

Dim itemList As Object
Set itemList = CreateObject("Scripting.Dictionary")

The cool thing about a dictionary is that it doesn't allow duplicates. However, you'd have to find a way to reference back to your class objects, so maybe just use a standard Collection rather than one just wrapped in a class.

You don't need to empty classes in VBA. As I mentioned asking about this -

 Set dataItems = Nothing: On Error Resume Next
 Set dataItems = countOrd(itemKey): On Error GoTo 0

Using the : like that is allowed, but it really isn't expected in VBA - it makes it more difficult to read. Plus, I'm not sure what the error handling is supposed to do here, are you just suppressing errors? That's not good error handling.

And here

If dataItems Is Nothing Then

Else

it's kind of sloppy. You should aim for something more clear without empty condition results -

If Not dateItems is Nothing Then

Bottleneck

I see you're pulling data off the sheet. One row at a time. It would be more efficient to pull that into an array and cycle through the array instead -

Dim oldOrders As Variant
oldOrders = oldWS.Range(oldWS.Cells(2, 1), oldWS.Cells(rowCount, 64))

There might be an easier way to get the data you want directly with the variant, but for now we can leave it like this. Once you're not hitting the sheet so many times, you'll see an incredible performance gain. It's similar to using .Select - Be sure to avoid things like .Select - it just slows the code down by needing to fiddle with the spreadsheet while doing everything else behind the scenes. There's a good question on StackOverflow addressing this.

Why are you using an INDIRECT? I mean, those have terrible performance as functions on the sheet. I think once you have you data in an array you'll see a better way to do that. Maybe create a resultsArray and move what should be included into that array, then spit that array out onto the newWS.

The same goes for the .Resize, .insert and .copy. Besides arrays, those are your bottlenecks.

Oh and something I noticed (as an example for learning):

 Public Sub InsertRows(splitVal As Integer, keyCells As Range)

'Call pw

Dim ws As Worksheet
Dim wb As Workbook

Set wb = ThisWorkbook
Set ws = wb.Worksheets("Orders")

Why not just pass the sheet into the sub?

Public Sub InsertRows(ByVal targetSheet as Worksheet, ByVal splitVal as Long, ByVal keyCells as Range) 
 targetSheet.Unprotect Password

Array Example

Incomplete example

Say you have two workbooks with tables:

Book1

Name Dept Job
Alice A Math
Bob A Math
Bob B Cryptography
Chuck B UI

Book2

Name Dept Job
Alice A Math
Bill B Manager

In this example you want to merge Book2 into Book1, adding information but not duplicating information. In Book1 you could run this macro to get all your data into arrays from both books -

Option Explicit

Sub MergeJobs()
 Dim sourceWorkbook As Workbook
 Dim targetWorkbook As Workbook
 Dim sourceData As Variant
 Dim lastRow As Long
 Dim path As String

 path = Application.GetOpenFilename(FileFilter:="Excel Files (*.XLS), *.XLS", Title:="Select File To Be Opened")
 Set sourceWorkbook = Application.Workbooks.Open(path)
 lastRow = sourceWorkbook.Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
 sourceData = sourceWorkbook.Sheet1.Range(sourceWorkbook.Sheet1.Cells(1, 1), sourceWorkbook.Sheet1.Cells(lastRow, 3))
 sourceWorkbook.Close (False)

 Dim sourceData As Variant
 Set targetWorkbook = activebook
 lastRow = targetWorkbook.Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
 sourceData = targetWorkbook.Sheet1.Range(targetWorkbook.Sheet1.Cells(1, 1), targetWorkbook.Sheet1.Cells(lastRow, 3))

End Sub

So now sourceData is the Book2 Table and targetData is the Book1 Table. Now you want to combine them -

Private Function CombineTables(ByVal sourceData As Variant, ByVal targetData As Variant) As Variant
Dim newData As Variant
Dim totalPossibleRows As Long
totalPossibleRows = UBound(sourceData, 1) + UBound(targetData, 1)
ReDim newData(totalPossibleRows, 2)
Dim currentEmployee As String

Dim sourceRow As Long
sourceRow = 1
Dim targetRow As Long
Dim newRow As Long
newRow = 1

Dim employees As Object
employees = CreateObject("Scripting.Dictionary")
For sourceRow = 2 To UBound(sourceData)
 employees(sourceData(sourceRow, 1)) = 1
Next
For targetRow = 2 To UBound(targetData)
 employees(targetData(targetRow, 1)) = 1
Next

Dim key As Variant
For Each key In employees.keys()
 currentEmployee = key
 For sourceRow = 2 To UBound(sourceData)
 If sourceData(sourceRow, 1) = currentEmployee Then
 newData(newRow, 1) = sourceData(sourceRow, 1)
 newData(newRow, 2) = sourceData(sourceRow, 2)
 newData(newRow, 3) = sourceData(sourceRow, 3)
 newRow = newRow + 1
 End If
 Next
 For targetRow = 2 To UBound(targetRow)
 If targetData(targetRow, 1) = currentEmployee Then
 newData(newRow, 1) = targetData(targetRow, 1)
 newData(newRow, 2) = targetData(targetRow, 2)
 newData(newRow, 3) = targetData(targetRow, 3)
 newRow = newRow + 1
 End If
 Next
Next

Now, we can sort the array. And then remove duplicates. You get the idea.