Fill a new Workbook with info from another workbook

Question

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.

Answer 1

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.