Fill in workbook with data from another workbook

Question

Followup to this 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.

The macro can import about 1500 rows and 24 columns full of information (dates, text, numbers) in 7-10 mins.

In this revision, I improved it by mainly decreasing the time it communicates with the Worksheet. Before, the code had to communicate 24*1500 times with the worksheet to save the data in the collection of classes. Now, I insert the whole worksheet into an array and I work with it. So now, I decreased the "save data into classes" part to a one-time only call to the worksheet.

Now, when passing the data into a new workbook is unavoidable to communicate with the workbook, most of the 7-10 mins is taken in this part where I have to iterate through the classes and checking with each row to find a match, pass the information, and delete the class.

I thought of adding the column POLINE of the new workbook into an array to save time, this improved the time 1-2 minutes actually because now VBA compares with an array and not with the worksheet itself.

I have further thoughts in sorting the POLINE column in both workbooks before any process, that way the macro will find matches much faster than having to iterate sometimes through the whole array (1 to 1500, 1 to 1) to find a match

REQUEST: I ask help in checking my error handling and my use of WBFast and WBNorm. My code relies heavily on Worksheet_Change events and WBFast and WBNorm are needed!

PS: The horrible chunk of Application.WorksheetFunction.Match() is needed since we changed some things in our workbook and columns were swapped! If there is a better way, I am all ears. (That part doesnt take too much time to get done and in a couple of weeks will be unneeded when most users start using the new workbook)

There are 7 modules, 2 classes, code in ThisWorkbook and Sheet1.

cPurcharseOrder (Class)

Private pPOLine 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 pPOrderStatus As String
Private pWorkProgress As String
Private pPODeliveryDate 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 pNewPODeliveryDate As String
Private pComments As String

Public Property Get POLine() As String
     POLine = pPOLine
End Property
Public Property Let POLine(Value As String)
    pPOLine = 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
'---------------PO 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 POrderStatus() As String
     POrderStatus = pPOrderStatus
End Property
Public Property Let POrderStatus(Value As String)
    If Value = "Shipping" Then Value = "In Progress"
    pPOrderStatus = 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 PODeliveryDate() As String
     PODeliveryDate = pPODeliveryDate
End Property
Public Property Let PODeliveryDate(Value As String)
    pPODeliveryDate = 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 NewPODeliveryDate() As String
     NewPODeliveryDate = pNewPODeliveryDate
End Property
Public Property Let NewPODeliveryDate(Value As String)
    pNewPODeliveryDate = 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

Get data from WB (Module1)

Sub GetDataFromWB()


    Call PW

    Dim fileName As Variant
    Dim oldOPO As Workbook, newOPO As Workbook
    Dim oldOPOTable As ListObject, newOPOTable As ListObject
    Dim rRows As Long
    Dim PO As CPurchaseOrder, dataItems As cItems
    Dim OPOInfo As Collection, countPO As Collection
    Dim itemKey As String
    Dim newWS As Worksheet, oldWS As Worksheet
    Dim wbCount As Long
    Dim i As Long
    Dim keyCells As Range, headerRow As Range
    Dim cel As Range
    Dim arrPO As Variant, arrNewPO As Variant

    Dim POLine As Long, LabDipStatus As Long, LabDipDate As Long, ReasonDelayLapDip As Long, OtherReasonDelayLabDip As Long, SubmitLabDip As Long, TrackingLabDip As Long
    Dim ProdLotStatus As Long, ProdLotDate As Long, ReasonDelayProdLot As Long, OtherReasonDelayProdLot As Long, SubmitProdLot As Long, TrackingProdLot As Long
    Dim ShipFrom As Long, POStatus As Long, WorkProgress As Long, PODeliveryDate As Long, RealQtyShipped As Long
    Dim ShipMode As Long, Container As Long, Invoice As Long, ReasonChange As Long, OtherReasonChange As Long, NewPODeliveryDate As Long, Comments As Long

    Dim StartTime As Double
    Dim MinutesElapsed As String

    StartTime = Timer

    On Error GoTo ErrorHandler

    fileName = Application.GetOpenFilename("Excel files (*.xls*), *.xls*", 1, "Select a OPO Workbook")

    Set newOPO = ThisWorkbook
    Set newWS = newOPO.Worksheets("Open Orders")
    Set newOPOTable = newWS.ListObjects("TableQuery")
    Set oldOPO = Workbooks.Open(fileName)
    Set oldWS = oldOPO.Worksheets("Open Orders")
    Set oldOPOTable = oldWS.ListObjects("TableQuery")
    Set headerRow = oldOPOTable.HeaderRowRange

    Set OPOInfo = New Collection
    Set countPO = New Collection

    WBFast


    POLine = Application.WorksheetFunction.Match("PO/Line", headerRow, 0)
    LabDipStatus = Application.WorksheetFunction.Match("Lab dip status", headerRow, 0)
    LabDipDate = Application.WorksheetFunction.Match("Submit date", headerRow, 0)
    ReasonDelayLapDip = Application.WorksheetFunction.Match("Reason for delay (Lab dip)", headerRow, 0)
    OtherReasonDelayLabDip = Application.WorksheetFunction.Match("Other Reason for Delay (Lab dip)", headerRow, 0)
    SubmitLabDip = Application.WorksheetFunction.Match("# Submit Lab Dip", headerRow, 0)
    TrackingLabDip = Application.WorksheetFunction.Match("Tracking Lab Dip", headerRow, 0)
    ProdLotStatus = Application.WorksheetFunction.Match("Prod Lot Status", headerRow, 0)
    ProdLotDate = Application.WorksheetFunction.Match("Submit prod lot date", headerRow, 0)
    ReasonDelayProdLot = Application.WorksheetFunction.Match("Reason for delay (Prod Lot)", headerRow, 0)
    OtherReasonDelayProdLot = Application.WorksheetFunction.Match("Other Reason for Delay (Prod Lot)", headerRow, 0)
    SubmitProdLot = Application.WorksheetFunction.Match("# Submit Prod Lot", headerRow, 0)
    TrackingProdLot = Application.WorksheetFunction.Match("Tracking Prod Lot", headerRow, 0)
    ShipFrom = Application.WorksheetFunction.Match("Ship from", headerRow, 0)
    POStatus = Application.WorksheetFunction.Match("PO Status", headerRow, 0)
    WorkProgress = Application.WorksheetFunction.Match("Work in progress", headerRow, 0)
    PODeliveryDate = Application.WorksheetFunction.Match("PO Dlvry Date", headerRow, 0)
    RealQtyShipped = Application.WorksheetFunction.Match("Real QTY shipped", headerRow, 0)
    ShipMode = Application.WorksheetFunction.Match("SHIPMODE", headerRow, 0)
    Container = Application.WorksheetFunction.Match("ASAP, AWB # or Container #", headerRow, 0)
    Invoice = Application.WorksheetFunction.Match("INVOICE #", headerRow, 0)
    ReasonChange = Application.WorksheetFunction.Match("REASON FOR CHANGE", headerRow, 0)
    OtherReasonChange = Application.WorksheetFunction.Match("Other Reason for Change", headerRow, 0)
    NewPODeliveryDate = Application.WorksheetFunction.Match("NEW PO Dlvry Date", headerRow, 0)
    Comments = Application.WorksheetFunction.Match("COMMENTS", headerRow, 0)

    arrPO = oldOPOTable.DataBodyRange.Value2
    oldOPO.Close False

    For rRows = 1 To UBound(arrPO)
        If Len(arrPO(1, 64)) > 11 Then
            itemKey = CStr(arrPO(rRows, POLine))

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

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

            With dataItems
                .Count = .Count + 1
            End With


            '------OLD OPO INFO------'
            On Error Resume Next
            Set PO = New CPurchaseOrder
            PO.POLine = arrPO(rRows, POLine)

            PO.LabDipStatus = arrPO(rRows, LabDipStatus)
            PO.LabDipDate = arrPO(rRows, LabDipDate)
            PO.ReasonDelayLapDip = arrPO(rRows, ReasonDelayLapDip)
            PO.OtherReasonDelayLabDip = arrPO(rRows, OtherReasonDelayLabDip)
            PO.SubmitLabDip = arrPO(rRows, SubmitLabDip)
            PO.TrackingLabDip = arrPO(rRows, TrackingLabDip)

            PO.ProdLotStatus = arrPO(rRows, ProdLotStatus)
            PO.ProdLotDate = arrPO(rRows, ProdLotDate)
            PO.ReasonDelayProdLot = arrPO(rRows, ReasonDelayProdLot)
            PO.OtherReasonDelayProdLot = arrPO(rRows, OtherReasonDelayProdLot)
            PO.SubmitProdLot = arrPO(rRows, SubmitProdLot)
            PO.TrackingProdLot = arrPO(1, TrackingProdLot)

            PO.ShipFrom = arrPO(rRows, ShipFrom)
            PO.POrderStatus = arrPO(rRows, POStatus)
            PO.WorkProgress = arrPO(rRows, WorkProgress)
            PO.PODeliveryDate = arrPO(rRows, PODeliveryDate)
            PO.RealQtyShipped = arrPO(rRows, RealQtyShipped)
            PO.ShipMode = arrPO(rRows, ShipMode)
            PO.Container = arrPO(rRows, Container)
            PO.Invoice = arrPO(rRows, Invoice)
            PO.ReasonChange = arrPO(rRows, ReasonChange)
            PO.OtherReasonChange = arrPO(rRows, OtherReasonChange)
            PO.NewPODeliveryDate = arrPO(rRows, NewPODeliveryDate)

            OPOInfo.Add PO
        End If
    Next rRows

    For Each cel In newOPOTable.ListColumns("PO/LINE").DataBodyRange
        itemKey = CStr(cel.Value2)
        Set dataItems = Nothing: On Error Resume Next
        Set dataItems = countPO(itemKey): On Error GoTo 0

        If dataItems Is Nothing Then

        Else
            If dataItems.Count > 1 Then
                Set keyCells = Intersect(cel.EntireRow, newOPOTable.DataBodyRange)
                Call InsertRows(dataItems.Count - 1, keyCells, newWS)
                countPO.Remove itemKey
            End If
        End If
    Next cel

    newWS.Cells.Validation.Delete

    Set headerRow = Nothing
    Set headerRow = newOPOTable.HeaderRowRange

    POLine = Application.WorksheetFunction.Match("PO/Line", headerRow, 0)
    LabDipStatus = Application.WorksheetFunction.Match("Lab dip status", headerRow, 0)
    LabDipDate = Application.WorksheetFunction.Match("Submit date", headerRow, 0)
    ReasonDelayLapDip = Application.WorksheetFunction.Match("Reason for delay (Lab dip)", headerRow, 0)
    OtherReasonDelayLabDip = Application.WorksheetFunction.Match("Other Reason for Delay (Lab dip)", headerRow, 0)
    SubmitLabDip = Application.WorksheetFunction.Match("# Submit Lab Dip", headerRow, 0)
    TrackingLabDip = Application.WorksheetFunction.Match("Tracking Lab Dip", headerRow, 0)
    ProdLotStatus = Application.WorksheetFunction.Match("Prod Lot Status", headerRow, 0)
    ProdLotDate = Application.WorksheetFunction.Match("Submit prod lot date", headerRow, 0)
    ReasonDelayProdLot = Application.WorksheetFunction.Match("Reason for delay (Prod Lot)", headerRow, 0)
    OtherReasonDelayProdLot = Application.WorksheetFunction.Match("Other Reason for Delay (Prod Lot)", headerRow, 0)
    SubmitProdLot = Application.WorksheetFunction.Match("# Submit Prod Lot", headerRow, 0)
    TrackingProdLot = Application.WorksheetFunction.Match("Tracking Prod Lot", headerRow, 0)
    ShipFrom = Application.WorksheetFunction.Match("Ship from", headerRow, 0)
    POStatus = Application.WorksheetFunction.Match("PO Status", headerRow, 0)
    WorkProgress = Application.WorksheetFunction.Match("Work in progress", headerRow, 0)
    PODeliveryDate = Application.WorksheetFunction.Match("PO Dlvry Date", headerRow, 0)
    RealQtyShipped = Application.WorksheetFunction.Match("Real QTY shipped", headerRow, 0)
    ShipMode = Application.WorksheetFunction.Match("SHIPMODE", headerRow, 0)
    Container = Application.WorksheetFunction.Match("ASAP, AWB # or Container #", headerRow, 0)
    Invoice = Application.WorksheetFunction.Match("INVOICE #", headerRow, 0)
    ReasonChange = Application.WorksheetFunction.Match("REASON FOR CHANGE", headerRow, 0)
    OtherReasonChange = Application.WorksheetFunction.Match("Other Reason for Change", headerRow, 0)
    NewPODeliveryDate = Application.WorksheetFunction.Match("NEW PO Dlvry Date", headerRow, 0)
    Comments = Application.WorksheetFunction.Match("COMMENTS", headerRow, 0)

    arrNewPOs = newOPOTable.ListColumns(8).Range.Value2

    For rRows = 2 To UBound(arrNewPOs)
        For i = OPOInfo.Count To 1 Step -1
            Set PO = OPOInfo(i)
            If arrNewPOs(rRows, 1) = PO.POLine Then
                newWS.Cells(rRows, LabDipStatus) = PO.LabDipStatus
                newWS.Cells(rRows, LabDipDate) = PO.LabDipDate
                newWS.Cells(rRows, ReasonDelayLapDip) = PO.ReasonDelayLapDip
                newWS.Cells(rRows, OtherReasonDelayLabDip) = PO.OtherReasonDelayLabDip
                newWS.Cells(rRows, SubmitLabDip) = PO.SubmitLabDip
                newWS.Cells(rRows, TrackingLabDip) = PO.TrackingLabDip

                newWS.Cells(rRows, ProdLotStatus) = PO.ProdLotStatus
                newWS.Cells(rRows, ProdLotDate) = PO.ProdLotDate
                newWS.Cells(rRows, ReasonDelayProdLot) = PO.ReasonDelayProdLot
                newWS.Cells(rRows, OtherReasonDelayProdLot) = PO.OtherReasonDelayProdLot
                newWS.Cells(rRows, SubmitProdLot) = PO.SubmitProdLot
                newWS.Cells(rRows, TrackingProdLot) = PO.TrackingProdLot

                newWS.Cells(rRows, ShipFrom) = PO.ShipFrom
                newWS.Cells(rRows, POStatus) = PO.POrderStatus
                newWS.Cells(rRows, WorkProgress) = PO.WorkProgress
                newWS.Cells(rRows, PODeliveryDate) = PO.PODeliveryDate
                newWS.Cells(rRows, RealQtyShipped) = PO.RealQtyShipped
                newWS.Cells(rRows, ShipMode) = PO.ShipMode
                newWS.Cells(rRows, Container) = PO.Container
                newWS.Cells(rRows, Invoice) = PO.Invoice
                newWS.Cells(rRows, ReasonChange) = PO.ReasonChange
                newWS.Cells(rRows, OtherReasonChange) = PO.OtherReasonChange
                newWS.Cells(rRows, NewPODeliveryDate) = PO.NewPODeliveryDate

                OPOInfo.Remove i
                Exit For
            End If
        Next i
    Next rRows

    newWS.Unprotect Password

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

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

    Set keyCells = newOPOTable.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 = newOPOTable.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 = newOPOTable.ListColumns("PO Status").DataBodyRange
    Call DoValidation("Wrong value", 3, "=INDIRECT(""TablePOStatus[POStatus]"")", keyCells, "Choose a value from drop down list")

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


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

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

    MinutesElapsed = format((Timer - StartTime) / 86400, "hh:mm:ss")

    MsgBox "This code ran successfully in " & MinutesElapsed & " seconds.", vbInformation, "Imported Data Successfully"

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

ErrorHandler:
        Select Case Err.Number
            Case 9
                MsgBox "Column, sheet or table not found. Check names in file have not changed and try again." & vbNewLine & _
                "Get_Data module |" & Err.Number & ": " & Err.Description & ".", vbInformation, "Not found"
            Case Else
                MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Worksheet_Change, line " & Erl & "."
        GoTo ExitHandler
End Sub

Insert Rows (Module2)

Sub InsertRows(ByVal splitVal As Integer, ByVal keyCells As Range, ws As Worksheet)

    PW
    ws.Unprotect Password
    WBFast
    With keyCells
        .Offset(1).Resize(splitVal).EntireRow.Insert
        .EntireRow.Copy .Offset(1, 0).Resize(splitVal).EntireRow
    End With

End Sub

Various Subs (Module3)

Option Compare Text
Option Explicit

Public Password As String

Sub PW()
    Password = "planning18"
End Sub

Sub WBFast()
    With ThisWorkbook.Application
        .EnableEvents = False
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
End Sub

Sub WBNorm()
    With ThisWorkbook.Application
        .EnableEvents = True
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

'This is to automatically fill down columns in Open Orders with data selected by user in Vendor sheet
Sub FillData()

    Dim tblControl As ListObject, tblQuery As ListObject
    Dim wb As Workbook
    Dim wsVen As Worksheet, wsOPO As Worksheet
    Dim cel As Range


    Set wb = ThisWorkbook
    Set wsVen = wb.Worksheets("Vendor")
    Set wsOPO = wb.Worksheets("Open Orders")

    Set tblControl = wsVen.ListObjects("TableControl")
    Set tblQuery = wsOPO.ListObjects("TableQuery")

    WBFast
    For Each cel In tblControl.ListColumns("CONTROL").DataBodyRange
        Select Case cel.Value2
            Case "FILL_SHIPMODE"
                If cel.Offset(0, 2).Value2 = "YES" Then tblQuery.ListColumns("SHIPMODE").DataBodyRange.Value2 = cel.Offset(0, 1).Value2
            Case "FILL_SHIPFROM"
                If cel.Offset(0, 2).Value2 = "YES" Then tblQuery.ListColumns("SHIP FROM").DataBodyRange.Value2 = cel.Offset(0, 1).Value2
            Case "REQUESTER"
                If cel.Offset(0, 2).Value2 = "YES" Then Call DeleteFilterCriteria(cel.Offset(0, 1).Value2, tblQuery, 5)
            Case "COMPANY"
                If cel.Offset(0, 2).Value2 = "YES" Then Call DeleteFilterCriteria(cel.Offset(0, 1).Value2, tblQuery, 2)
            Case "COMPLETE"
                If cel.Offset(0, 2).Value2 = "YES" Then Call DeleteFilterCriteria(cel.Offset(0, 1).Value2, tblQuery, 19)
            Case Else

        End Select
    Next cel

    tblQuery.ListColumns("USER").DataBodyRange.Value2 = UserName

    WBNorm

End Sub

Sub LightWB()

    Dim wb As Workbook
    Dim NewFileName As String
    Dim NewFileFilter As String
    Dim myTitle As String
    Dim FileSaveName As Variant
    Dim NewFileFormat As Long

    Set wb = ThisWorkbook


    If Application.Version >= 12 Then
        NewFileName = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5)
        NewFileFilter = "Excel Binary Workbook (*.xlsb), *.xlsb"
        NewFileFormat = 52
    Else
        NewFileName = wb.Sheets("Sheet1").Range("B18").Value & ".xls"
        NewFileFilter = "Microsoft Excel Workbook (*.xls), *.xls"
        NewFileFormat = xlNormal
    End If

    myTitle = "Navigate to the required folder"

    FileSaveName = Application.GetSaveAsFilename _
            (InitialFileName:=NewFileName, _
             FileFilter:=NewFileFilter, _
             Title:=myTitle)
    If Not FileSaveName = False Then
      wb.SaveAs fileName:=FileSaveName, _
                    FileFormat:=NewFileFormat
    Else
        MsgBox "File NOT Saved. User cancelled the Save."
    End If

End Sub

Sub DeleteFilterCriteria(xCriteria As String, tblTarget As ListObject, filterColumn As Long)

    Call PW

    Dim ws As Worksheet
    Dim wb As Workbook
    Dim rngDel As Range, cel As Range
    Dim a As Long

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

    'ws.Unprotect Password
    tblTarget.ShowAutoFilter = False
    tblTarget.ShowAutoFilter = True

    With tblTarget
        .Range.AutoFilter Field:=filterColumn, Criteria1:=xCriteria, Operator:=xlFilterValues
        On Error Resume Next
        Set rngDel = Intersect(.DataBodyRange, .DataBodyRange.SpecialCells(xlCellTypeVisible))
    End With

    If Not rngDel Is Nothing Then
        For a = rngDel.Areas.Count To 1 Step -1
            rngDel.Areas(a).EntireRow.Delete
        Next a
    End If

    tblTarget.ShowAutoFilter = False
    tblTarget.ShowAutoFilter = True

End Sub

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
Public Function UserName()
    UserName = Environ$("UserName")
End Function

Refresh queries (Module4)

Sub RefreshOpenOrders()

    PW
    Dim wb As Workbook, ws As Worksheet

    On Error GoTo RefreshError
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Open Orders")

    WBFast
    ws.Unprotect Password:=Password
    ws.ListObjects("TableQuery").QueryTable.Refresh
    ws.Protect Password:=Password, DrawingObjects:=False, Contents:=True, Scenarios:=False _
    , AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True, AllowFormattingCells:=True, AllowFormattingRows:=True, AllowFormattingColumns:=True

    MsgBox "Remember to refresh the other tables in the workbook", vbInformation, "Refresh All"

    Call FillData

    WBNorm

    Exit Sub

RefreshError:
    WBNorm
    MsgBox Err.Number & " " & Err.Description, vbOKOnly, "Refresh Open Orders Query"
    ws.Protect Password:=Password, DrawingObjects:=False, Contents:=True, Scenarios:=False _
    , AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True, AllowFormattingCells:=True, AllowFormattingRows:=True, AllowFormattingColumns:=True

End Sub

Sub RefreshAll()

    Call PW
    Dim wb As Workbook, ws As Worksheet

    On Error GoTo RefreshError
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Open Orders")

    WBFast

    ws.Unprotect Password:=Password
    wb.RefreshAll
    ws.Protect Password:=Password, DrawingObjects:=False, Contents:=True, Scenarios:=False _
    , AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True, AllowFormattingCells:=True, AllowFormattingRows:=True, AllowFormattingColumns:=True


    MsgBox "All tables refreshed", vbInformation, "Refresh All"

    Call FillData

    WBNorm

    Exit Sub

RefreshError:
    WBNorm
    MsgBox Err.Number & " " & Err.Description, vbOKOnly, "Refresh All"
    ws.Protect Password:=Password, DrawingObjects:=False, Contents:=True, Scenarios:=False _
    , AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True, AllowFormattingCells:=True, AllowFormattingRows:=True, AllowFormattingColumns:=True

End Sub

Delete tbl rows (Module5)

Sub DeleteTableRows()
    'PURPOSE: Delete table row based on user's selection
    'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault
    Call PW


    Dim rng As Range
    Dim DeleteRng As Range
    Dim cell As Range
    Dim TempRng As Range
    Dim Answer As Variant
    Dim area As Range
    Dim ReProtect As Boolean
    Dim copyRange As Range
    Dim pasteRange As Range
    Dim wb As Workbook
    Dim a As Long

    WBFast

    'Set Range Variable
      On Error GoTo InvalidSelection
        Set rng = Selection
      On Error GoTo 0


    'Unprotect Worksheet
      With ThisWorkbook.ActiveSheet
        If .ProtectContents Or ProtectDrawingObjects Or ProtectScenarios Then
          On Error GoTo InvalidPassword
          .Unprotect Password
          ReProtect = True
          On Error GoTo 0
        End If
      End With

      Set wb = ThisWorkbook

    'Loop Through each Area in Selection
      For Each area In rng.Areas
        For Each cell In area.Cells.Columns(1)
          'Is selected Cell within a table?
            InsideTable = True

          'Gather rows to delete
            If InsideTable Then
              On Error GoTo InvalidActiveCell
              Set TempRng = Intersect(cell.EntireRow, ActiveCell.ListObject.DataBodyRange)
              On Error GoTo 0

              If DeleteRng Is Nothing Then
                Set DeleteRng = TempRng
              Else
                Set DeleteRng = Union(TempRng, DeleteRng)
              End If

            End If

        Next cell
      Next area


    'Error Handling
      If DeleteRng Is Nothing Then GoTo InvalidSelection
      If DeleteRng.Address = ActiveCell.ListObject.DataBodyRange.Address Then GoTo DeleteAllRows
      If ActiveCell.ListObject.DataBodyRange.Rows.Count = 1 Then GoTo DeleteOnlyRow

    'Ask User To confirm delete (since this cannot be undone)
        DeleteRng.Select

        If DeleteRng.Rows.Count = 1 And DeleteRng.Areas.Count = 1 Then
          Answer = MsgBox("Are you sure you want to delete the currently selected table row? " & _
           " This cannot be undone...", vbYesNo, "Delete Row?")
        Else
          Answer = MsgBox("Are you sure you want to delete the currently selected table rows? " & _
           " This cannot be undone...", vbYesNo, "Delete Rows?")
        End If

    'Delete row (if wanted)
      If Answer = vbYes Then


        For a = DeleteRng.Areas.Count To 1 Step -1
            Debug.Print DeleteRng.Areas.Count
            DeleteRng.Areas(a).EntireRow.Delete
        Next a


        WBNorm

      End If

    'Protect Worksheet
      If ReProtect = True Then wb.Worksheets("Open Orders").Protect Password:=Password, DrawingObjects:=True, Contents:=True, Scenarios:=False _
    , AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True, AllowFormattingRows:=True, AllowFormattingColumns:=True, AllowFormattingCells:=True
    Exit Sub

    'ERROR HANDLERS

InvalidActiveCell:
      MsgBox "The first cell you select must be inside an Excel Table. " & _
       "The first cell you selected was cell " & ActiveCell.Address, vbCritical, "Invalid Selection!"
      If ReProtect = True Then wb.Worksheets("Open Orders").Protect Password:=Password, DrawingObjects:=True, Contents:=True, Scenarios:=False _
    , AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True, AllowFormattingRows:=True, AllowFormattingColumns:=True, AllowFormattingCells:=True
      Application.EnableEvents = True
      Exit Sub

InvalidSelection:
      MsgBox "You must select a cell within an Excel table", vbCritical, "Invalid Selection!"
      If ReProtect = True Then wb.Worksheets("Open Orders").Protect Password:=Password, DrawingObjects:=True, Contents:=True, Scenarios:=False _
    , AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True, AllowFormattingRows:=True, AllowFormattingColumns:=True, AllowFormattingCells:=True
      Application.EnableEvents = True
      Exit Sub

DeleteAllRows:
      MsgBox "You cannot delete all the rows in the table. " & _
       "You must leave at least one row existing in a table", vbCritical, "Cannot Delete!"
      If ReProtect = True Then wb.Worksheets("Open Orders").Protect Password:=Password, DrawingObjects:=True, Contents:=True, Scenarios:=False _
    , AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True, AllowFormattingRows:=True, AllowFormattingColumns:=True, AllowFormattingCells:=True
      Application.EnableEvents = True
      Exit Sub

DeleteOnlyRow:
      MsgBox "You cannot delete the only row in the table.", vbCritical, "Cannot Delete!"
      If ReProtect = True Then wb.Worksheets("Open Orders").Protect Password:=Password, DrawingObjects:=True, Contents:=True, Scenarios:=False _
    , AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True, AllowFormattingRows:=True, AllowFormattingColumns:=True, AllowFormattingCells:=True
      Application.EnableEvents = True
      Exit Sub

InvalidPassword:
      MsgBox "Failed to unlock password with the following password: " & Password
      Application.EnableEvents = True
      Exit Sub

End Sub

Date check (Module6)

Option Explicit

Sub DateCheck(Target As Range)


    Dim numDate As Double, poDate As Double
    Dim cel As Range
    Dim xTimelimit As Integer, xWrongFormat As Integer
    Dim ans As String
    Dim tblControl As ListObject
    Dim wb As Workbook

    Set wb = ThisWorkbook
    Set tblControl = wb.Worksheets("Vendor").ListObjects("TableControl")

    ans = wb.Application.WorksheetFunction.Index(tblControl.ListColumns("ACTIVATE").DataBodyRange, Application.WorksheetFunction.Match("DATE_RESTRICTION", tblControl.ListColumns("CONTROL").DataBodyRange, 0))

    For Each cel In Target
        On Error Resume Next
        numDate = DateValue(cel.Value)
        If numDate > 0 Then
            poDate = Cells(cel.Row, 4).Value2
            If (((numDate > (poDate + 161)) Or (numDate < (DateValue(Now()) - 161))) And (ans = "YES")) Then
                cel.ClearContents
                xTimelimit = xTimelimit + 1
            Else
                cel = numDate
                cel.NumberFormat = "dd-mmm-yyyy"
            End If
        Else
            If ((cel.Value Like "WK?") Or (cel.Value Like "WK??")) And (cel.Column <> 49 And cel.Column <> 60) Or (IsEmpty(cel.Value) Or IsNull(cel.Value)) Then
                Resume Next
            Else
                cel.ClearContents
                xWrongFormat = xWrongFormat + 1
            End If
        End If
    Next cel

    If xTimelimit > 0 Then
        MsgBox "There are " & xTimelimit & " date(s) that are outside our time limit of 23 weeks of leadtime for a PO, starting from the day it was set." _
        & vbNewLine & "Please check if the date(s) entered are correct, row(s) will be in red. If you believe the date(s) are fine, contact your material planner." _
        , vbInformation + vbOKOnly, "Above Time Limit"
    End If

    If xWrongFormat > 0 Then
        MsgBox "There are " & xWrongFormat & " date(s) with wrong date format. Row(s) are in red." _
        & vbNewLine & "Check guideline for more information.", vbOKOnly + vbInformation, "Wrong format"
    End If
End Sub

Clear tbl (Module7)

Sub ClearTableContents()
    Dim tbl As ListObject
    Dim clrRng As Range, cel As Range
    Dim wb As Workbook
    Dim rng1 As Range, rng2 As Range, rng3 As Range

    If MsgBox("This will clear the table Open Orders" & vbNewLine & _
    "Do you wish to use it?", vbYesNo + vbInformation, "Untested Macro") = vbNo Then Exit Sub

    WBFast

    Set wb = ThisWorkbook
    Set tbl = wb.Worksheets("Open Orders").ListObjects("TableQuery")

    Set rng1 = Range(tbl & "[[Lab dip status]:[Real QTY shipped]]")
    Set rng2 = Union(tbl.ListColumns("SHIPMODE").DataBodyRange, tbl.ListColumns("ASAP, AWB # or Container #").DataBodyRange, tbl.ListColumns("INVOICE #").DataBodyRange)
    Set rng3 = Union(tbl.ListColumns("REASON FOR CHANGE").DataBodyRange, tbl.ListColumns("Other Reason for Change").DataBodyRange, tbl.ListColumns("NEW PO Dlvry Date").DataBodyRange)

    Set clrRng = Union(rng1, rng2, rng3)
    clrRng.ClearContents

    WBNorm

End Sub

Worksheet Change Event (Sheet1)

Option Explicit
Option Compare Text

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim tbl As ListObject
    Dim splitVal As Long
    Dim colName As String
    Dim keyCells As Range, cel As Range, qtySplitRng As Range, chngReasonRng As Range
    Dim blckdRng As Range, dateRng As Range, openPOCheck As Range, qtyShippedRng As Range
    Dim dict As Object
    Dim dontSplit As Boolean: dontSplit = True
    Dim wb As Workbook, ws As Worksheet
    Dim totShipped As Long, openQty As Long

    On Error GoTo ErrorHandler

    'PW
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Open Orders")
    Set dict = CreateObject("Scripting.Dictionary")
    Set tbl = ws.ListObjects(1)
    Set qtySplitRng = tbl.ListColumns("Qty of shipments").Range
    Set chngReasonRng = Union(tbl.ListColumns("Other Reason for Change").Range, tbl.ListColumns("Other Reason for Delay (Prod Lot)").Range, tbl.ListColumns("Other Reason for Delay (Lab dip)").Range)
    Set blckdRng = Union(Range("LateDaysRange"), Range("ETARange"), Range("LeadTimeRange"), Range("QueryRange"), tbl.ListColumns("COMMENTS").Range, tbl.ListColumns("CHECK").Range)
    Set dateRng = Union(tbl.ListColumns("Submit date").Range, tbl.ListColumns("Submit prod lot date").Range, tbl.ListColumns("Work in progress").Range, tbl.ListColumns("PO Dlvry Date").Range, tbl.ListColumns("NEW PO Dlvry Date").Range)
    Set qtyShippedRng = tbl.ListColumns("Real QTY shipped").DataBodyRange

    dict.Add "Other Reason for Change", "PO Delivery Date"
    dict.Add "Other Reason for Delay (Prod Lot)", "Prod Lot Date"
    dict.Add "Other Reason for Detail (Lab Dip)", "Lab Dip Date"

    If Intersect(Target, qtySplitRng) Is Nothing Then
        If Intersect(Target, qtyShippedRng) Is Nothing Then
            If Intersect(Target, chngReasonRng) Is Nothing Then
                If Intersect(Target, blckdRng) Is Nothing Then
                    If Intersect(Target, dateRng) Is Nothing Then
                        Exit Sub
                    Else
                        WBFast
                        Call DateCheck(Target)
                        GoTo ExitHandler
                    End If
                Else
                    WBFast
                    Application.Undo
                    MsgBox "You tried to edit a blocked range.", vbInformation, "Blocked Range"
                    GoTo ExitHandler
                End If
            Else
                WBFast
                For Each cel In Target.Cells
                    Set keyCells = cel.Offset(, -1)
                    colName = Cells(1, cel.Column)
                    Select Case keyCells.Value2
                        Case "Other"

                        Case Else
                            cel.ClearContents
                            MsgBox "You tried to edit a blocked range." & vbNewLine & "Choose a reason for changing " & dict.Item(colName) & " from the dropdown list in " & keyCells.Address & ". If the reason is not there, choose OTHER and then write down your reason here.", vbInformation, "Blocked Range"
                            GoTo ExitHandler
                    End Select
                Next cel
                GoTo ExitHandler
            End If
        Else
            WBFast
            totShipped = Application.WorksheetFunction.SumIf(tbl.ListColumns("PO/LINE").DataBodyRange, Target.Offset(0, -42).Value2, tbl.ListColumns("Real QTY shipped").DataBodyRange)
            openQty = Target.Offset(0, -32).Value2
            totShipped = totShipped - (openQty * 0.15)
            If totShipped > openQty Then
                Target.ClearContents
                MsgBox "You are shipping " & totShipped & " units in total with or without splits out of " & _
                openQty & " requested originally in column R. Revise your information is okay please.", vbOKOnly + vbInformation, "Shipping Excess"
            End If
            GoTo ExitHandler
        End If
    Else
        dontSplit = False
    End If

    If Target.CountLarge > 1 Then GoTo ExitHandler
    If (IsNull(Target.Value) Or IsEmpty(Target.Value) Or dontSplit) Then GoTo ExitHandler

    If IsNumeric(Target.Value) Then
        If Target.Value < 2 Then
            Target.ClearContents
            GoTo ExitHandler
        End If
    Else
        GoTo ExitHandler
    End If

    splitVal = Target.Value2 - 1
    Set keyCells = Intersect(Target.EntireRow, tbl.DataBodyRange)
    Target.ClearContents

    Call InsertRows(splitVal, keyCells, ws)

    On Error GoTo 0

ExitHandler:
    WBNorm
    'ws.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 "Error " & Err.Number & " (" & Err.Description & ") in procedure Worksheet_Change, line " & Erl & "."
    GoTo ExitHandler
End Sub

ThisWorkbook

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim tbl As ListObject
    Dim checkCol As Range
    Dim res As Integer
    Dim wb As Workbook

    Set checkCol = Range("TableQuery[CHECK]")

    res = Application.WorksheetFunction.CountIfs(checkCol, "<>In progress", checkCol, "<>RIGHT")

    If res > 0 Then
        Select Case MsgBox("There are " & res & " PO(s) with ambiguous information. They are highlighted in red. For more detail as to what is wrong, " & _
        "check the column " & Chr(34) & "BM" & Chr(34) & " in Open Orders sheet." & _
        vbNewLine & "Check your information please.", vbInformation + vbYesNo + vbDefaultButton1, "OPO Check")

        Case vbYes
            Cancel = True
        End Select
    End If

End Sub

Private Sub Workbook_Open()
    Dim tblQuery As ListObject, tblControl As ListObject
    Dim checkCol As Range
    Dim res As Integer
    Dim wb As Workbook
    Dim ans As String

    Set wb = ThisWorkbook
    Set tblQuery = wb.Worksheets("Open Orders").ListObjects("TableQuery")
    Set tblControl = wb.Worksheets("Vendor").ListObjects("TableControl")
    Set checkCol = Range("TableQuery[CHECK]")

    On Error Resume Next
    res = Application.WorksheetFunction.CountIfs(checkCol, "<>In progress", checkCol, "<>RIGHT")

    If res > 0 Then
        MsgBox "There are " & res & " PO(s) with ambiguous information. They are highlighted in red. For more detail as to what is wrong, check the column " & Chr(34) & "BM" & Chr(34) & " in Open Orders sheet", vbInformation, "OPO Check"
        On Error Resume Next
        wb.Worksheets("Open Orders").Activate
        tblQuery.ListColumns("CHECK").DataBodyRange.Select
    Else
        On Error Resume Next
        ans = wb.Application.WorksheetFunction.Index(tblControl.ListColumns("ACTIVATE").DataBodyRange, Application.WorksheetFunction.Match("GUIDELINE", tblControl.ListColumns("CONTROL").DataBodyRange, 0))
        If ans = "YES" Then wb.Worksheets("Guideline").Activate
    End If

End Sub

Since you've already posted a follow-up, you should accept the answer here. — t3chb0t
– t3chb0t, Commented Apr 20, 2018 at 8:49
Added all modules, I really need to up my game when asking for help. — rzenva
– rzenva, Commented Apr 20, 2018 at 13:41

paul bica · Accepted Answer · 2018-04-20 06:39:56Z

Not a full review, but just a suggestion about "The horrible chunk of Application.WorksheetFunction.Match()" as you put it

Considering you retrieve them several times, make a separate function (not sure if possible)

Option Explicit

Public Function GetHeadrs(ByRef headerRow As Range) As Dictionary
    Dim d As Dictionary, arr As Variant, col As Long

    Set d = New Dictionary
    If Not headerRow Is Nothing Then
        arr = headerRow
        For col = 1 To UBound(arr, 2)
            d(arr(1, col)) = col
        Next
    End If
    'Debug.Print d("PO/Line")
    Set GetHeadrs = d
End Function

Or just to make the sections a bit smaller, use the With Application.WorksheetFunction

With Application.WorksheetFunction
    POLine = .Match("PO/Line", headerRow, 0)
    LabDipStatus = .Match("Lab dip status", headerRow, 0)
    LabDipDate = .Match("Submit date", headerRow, 0)
    ReasonDelayLapDip = .Match("Reason for delay (Lab dip)", headerRow, 0)
    OtherReasonDelayLabDip = .Match("Other Reason for Delay (Lab dip)", headerRow, 0)
    SubmitLabDip = .Match("# Submit Lab Dip", headerRow, 0)
    TrackingLabDip = .Match("Tracking Lab Dip", headerRow, 0)
    ProdLotStatus = .Match("Prod Lot Status", headerRow, 0)
    ProdLotDate = .Match("Submit prod lot date", headerRow, 0)
    ReasonDelayProdLot = .Match("Reason for delay (Prod Lot)", headerRow, 0)
    OtherReasonDelayProdLot = .Match("Other Reason for Delay (Prod Lot)", headerRow, 0)
    SubmitProdLot = .Match("# Submit Prod Lot", headerRow, 0)
    TrackingProdLot = .Match("Tracking Prod Lot", headerRow, 0)
    ShipFrom = .Match("Ship from", headerRow, 0)
    POStatus = .Match("PO Status", headerRow, 0)
    WorkProgress = .Match("Work in progress", headerRow, 0)
    PODeliveryDate = .Match("PO Dlvry Date", headerRow, 0)
    RealQtyShipped = .Match("Real QTY shipped", headerRow, 0)
    ShipMode = .Match("SHIPMODE", headerRow, 0)
    Container = .Match("ASAP, AWB # or Container #", headerRow, 0)
    Invoice = .Match("INVOICE #", headerRow, 0)
    ReasonChange = .Match("REASON FOR CHANGE", headerRow, 0)
    OtherReasonChange = .Match("Other Reason for Change", headerRow, 0)
    NewPODeliveryDate = .Match("NEW PO Dlvry Date", headerRow, 0)
    Comments = .Match("COMMENTS", headerRow, 0)
End With

Using With never occured to me in this case! I will do as you say and I will try to use a dictionary as well! — rzenva
– rzenva, Commented Apr 20, 2018 at 12:14

Raystafarian · Accepted Answer · 2018-04-22 01:20:59Z

I still don't see a reason for the 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

You haven't really exposed anything from it and it works exactly as a collection does. You're wrapping a collection class in a collection class.

Collection has a count property and collection has a key parameter in the add method:

Public Sub Add (
    Item As Object,
    Key As String,
    Before As Object,
    After As Object
)

As far as I can tell, this is your only implementation:

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

        With dataItems
            .Count = .Count + 1
        End With

Which can be done without the wrapper.

You are right about collections, a dictionary would work too since I want to count duplicates — rzenva
– rzenva, Commented Apr 22, 2018 at 1:25

rzenva · Accepted Answer · 2018-04-23 20:27:10Z

0

Now, I am not sure what happened. Last update was the macro took 7-10 mins to import data, now it takes 15-20mins. That was a sudden increase since I have not changed anything.

answered Apr 23, 2018 at 20:27

rzenva

735 bronze badges

Add a comment |

Stack Exchange Network

Fill in workbook with data from another workbook

3 Answers 3

You must log in to answer this question.

Linked

Hot Network Questions

Fill in workbook with data from another workbook

3 Answers 3

You must log in to answer this question.

Linked

Related

Hot Network Questions