Transferring data utilising VBA

[bedsy]

Hi All,

I am trying to have code open and run through each workbook in the respective folder and return certain values from the sumifs that have multiple criteria multiple criteria.

Most of the code functions as required but the part I struggle with is having the arrival and departure details on separate worksheets and want them to input in the same worksheet.

the data pulled from sheet 1 ("Arrivals") will be in column "A" (OperatorName), "B" (Product), "C" (Arrival ID), "G" (wagons), "I" (Arrival time).
the data pulled from sheet 2 (Departures" will be in column "C" (DepartureID), "H" (Departure time)

In addition, if the source sheet has multiple instances that match the criteria it adds them and inputs the total value whereas I need it to input each occasion and not sure how to convert the code.

Also, I need to record the date of each respective record in Column "A". This is in Cell "O2" of each workbook.

Question: the time field in the source worksheet is formatted using 'Special - codigo Postal' to prevent having to insert ":" for each time input. any way for VBA to convert this back to a time format e.g 1745 becomes 17:45:00

Below is the code I currently have and a snapshot of the worksheet I need the data to be added to.

Sub OpenBooks()
  Dim sPath As String, MyFiles As String
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim wb2 As Workbook
  Dim i As Long
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  Set sh3 = ThisWorkbook.Sheets("Staged wagons")

  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Select Folder"
    If .Show <> -1 Then Exit Sub
    sPath = .SelectedItems(1) & "\"
  End With
 
  i = 1   'initial row to put the data
 
  MyFiles = Dir(sPath & "*.xlsx")
  Do While MyFiles <> ""
    Set wb2 = Workbooks.Open(sPath & MyFiles)
    Set sh2 = wb2.Sheets("Arrivals")
    With wb2.Sheets("Arrivals").Activate
    End With
    
    sh3.Range("B" & i + 2).Value = WorksheetFunction.SumIfs(sh2.Range("OperatorName"), sh2.Range("A4:A26"), "Operator", sh2.Range("B4:B26"), "Product") 'Operator
    sh3.Range("C" & i + 2).Value = WorksheetFunction.SumIfs(sh2.Range("G4:G26"), sh2.Range("A4:A26"), "Operator", sh2.Range("B4:B26"), "Product") ' wagons
    sh3.Range("E" & i + 2).Value = WorksheetFunction.SumIfs(sh2.Range("C4:C26"), sh2.Range("A4:A26"), "Operator", sh2.Range("B4:B26"), "Product") 'ID arrival
    sh3.Range("G" & i + 2).Value = WorksheetFunction.SumIfs(sh2.Range("M4:M26"), sh2.Range("A4:A26"), "Operator", sh2.Range("B4:B26"), "Product") 'actual arrival time
With wb2.Sheets("Departures").Activate
End With
    sh3.Range("H" & i + 2).Value = WorksheetFunction.SumIfs(sh2.Range("C4:C26"), sh2.Range("A4:A26"), "Operator", sh2.Range("B4:B26"), "Product") 'ID Depature
    sh3.Range("G" & i + 2).Value = WorksheetFunction.SumIfs(sh2.Range("H4:H26"), sh2.Range("A4:A26"), "Operator", sh2.Range("B4:B26"), "Product") 'actual depart time
        i = i + 1
    wb2.Close False

    MyFiles = Dir()
  Loop
 
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

Thanks Bedsy.

 

[bedsy]

A few more questions:

1. Each line in th ooutput is made up of arrival info and departure info. How do i know which departure belongs to which arrival? Is that the wagon(s) code, or the ID? (so is the departure ID the same as the arrival ID for the particular load)?
2. For your query you start with a operator name and product. How do you want to enter these? Through two input boxes? or through a userform with comboboxes, or another way?
3. I can also loop through all data and create an output sheet for each Operator/Product combination

ask as many as you would like....

1. The ID will be the same............. but (OfCourse there's a but) if a service departs after midnight another service with the same ID could potentially arrive and therefore depart on the same day. 99% of the time this will happen in sequence E.G. if service 1 departs @ 01:30hrs, the next service with the same ID will not arrive until after this time. I can not recall a time where we have had 2 services on location with the same ID at the same time. I should be able to identify any conflicts with a quick review of the output data.

2 . all data is just entered manually direct into the spreadsheet by a 3rd party.

3. Current state is I only need the output for the 1 operator. should this change in the future I would hopefully have enough knowledge to manipulate your code to produce the others...........finger crossed.

 

[sijpie]

Try this code. It looks pretty complicated. But I have added a lot of comments so you can follow better what is going on. It uses arrays for fast processing. A (2 dimensional) array is like a sheet held in memory. for instance the complete arrivals table is read (in one read operation) to the vArriv array. After that I can address each of the 'cells' in the array as vArriv(2,3) which would be the 2nd row, 3rd column.

For the output I also use an array, which at the end is written back to the sheet in one write operation.
As read and write operations are particularly slow in Excel, doing it this way makes everything really fast.

Let me know what you think

Option Explicit

Sub OpenBooksNew()
'// Macro that opens each workbook in selected dir and then lists the arrivals and _
 // departures of consignments for selected Operator and Product. _
 // Any departures that cannot be matched with arrival are seperatly listed for _
 // manual processing
 
    'arrays are used for fast processing of data
    Dim vArriv As Variant, vDep As Variant, vOut As Variant, vUnprocessed As Variant
    Dim lRa As Long, lRd As Long, lRo As Long, lC As Long, lC2 As Long, lRHa As Long, lRHd As Long, _
        UBa1 As Long, UBd1 As Long, UB1o As Long, UBa2 As Long, UBd2 As Long, lRSW As Long, _
        lCOa As Long, lCPa As Long, lCIDa As Long, lCLa As Long, lCWa As Long, _
        lCAT As Long, lCOd As Long, lCPd As Long, lCIDd As Long, lCDT As Long, lRe As Long
    Dim sPath As String, MyFiles As String
    Dim shArr As Worksheet, shDep As Worksheet, shOut As Worksheet
    Dim wbInput As Workbook
    Dim sOperator As String, sProduct As String
    Dim rFind As Range
    Dim dtArriv As Date, dtDep As Date
    
    Application.ScreenUpdating = False
    
    'check for output sheet
    For Each shOut In ThisWorkbook.Sheets
        If LCase(shOut.Name) Like "staged wagons" Then
            Exit For
        End If
    Next shOut
    If shOut Is Nothing Then        'sheet not found, so create
        ThisWorkbook.Sheets.Add
        Set shOut = ActiveSheet
        shOut.Name = "Staged Wagons"
    End If
    shOut.Range("A1").CurrentRegion.ClearContents       '<<< Comment out this line to add current filtered data to existing sheet
    lRSW = shOut.Cells(shOut.Rows.Count, 1).End(xlUp).Row
    If lRSW = 1 Then     'add headings to output sheet
        ReDim vOut(1 To 1, 1 To 8)
        vOut(1, 1) = "Date"
        vOut(1, 2) = "Operator"
        vOut(1, 3) = "Wagons"
        vOut(1, 4) = "Location"
        vOut(1, 5) = "Arriv ID"
        vOut(1, 6) = "Arriv Time"
        vOut(1, 7) = "Dep ID"
        vOut(1, 8) = "Dep Time"
        shOut.Range("A1").Resize(1, 8).Value = vOut
    End If
    
    ' select folder where input sheet sit
    With Application.FileDialog(msoFileDialogFolderPicker)
      .Title = "Select Folder"
      If .Show <> -1 Then Exit Sub      'user cancelled
      sPath = .SelectedItems(1) & "\"
    End With
    
    'Get the Operator and Product to filter on <<< this can also be achieved in other ways, but for now a simple inputbox
    sOperator = InputBox("Which operator is to be filtered on?", "Filter on Operator")
    If Len(sOperator) = 0 Then Exit Sub
    sOperator = LCase(sOperator)
    sProduct = InputBox("Which Product/ Commodity is to be filtered on?", "Filter on Product")
    If Len(sProduct) = 0 Then Exit Sub
    sProduct = LCase(sProduct)
    
    'Find the first input file in the selected folder
    MyFiles = Dir(sPath & "*.xlsx")
    'for each file in the folder
    Do While MyFiles <> ""
        'open input file
        Set wbInput = Workbooks.Open(sPath & MyFiles)
        'find Arrivals and Departures sheets
        For Each shArr In wbInput.Sheets
            If shArr.Name Like "Arrivals" Then
                Exit For
            End If
        Next shArr
        For Each shDep In wbInput.Sheets
            If shDep.Name Like "Departures" Then
                Exit For
            End If
        Next shDep
        If shArr Is Nothing Or shDep Is Nothing Then
            GoTo NextFile       'the workbook does not have the required input sheets
        End If
        
        'find the start of the database
        Set rFind = shArr.Cells.Find("Operator")
        If rFind Is Nothing Then GoTo NextFile
        'fill the Arrival array with the database
        vArriv = rFind.CurrentRegion.Value
        'find the start of the database
        Set rFind = shDep.Cells.Find("Operator")
        If rFind Is Nothing Then GoTo NextFile
        'fill the departure array with the database, add one extra column
        With rFind
            vDep = .Resize(.CurrentRegion.Rows.Count, .CurrentRegion.Columns.Count + 1).Value
        End With
        
        'close the input workbook
        wbInput.Close SaveChanges:=False
        
        'store number of rows in each array
        UBa1 = UBound(vArriv, 1)
        UBd1 = UBound(vDep, 1)
        'store number of columns in each array
        UBa2 = UBound(vArriv, 2)
        UBd2 = UBound(vDep, 2)
        
        'Size the output array
        ReDim vOut(1 To UBa1 + UBd1, 1 To 8) 'output array - set to maximum posible rows
        
        
        'get header row and relevant columns for each of the input arrays. _
         This is in case the column order is changed by a user
        For lRa = 1 To UBa1
            For lC = 1 To UBa2
                If LCase(vArriv(lRa, lC)) Like "operator" Then
                    lRHa = lRa
                    lCOa = lC
                    For lC2 = 1 To UBa2
                        Select Case LCase(vArriv(lRHa, lC2))    '<<< the column headers (lower case). _
                                                if these change, the names below need to be adjusted
                            Case "commodity"
                                lCPa = lC2
                            Case "id"
                                lCIDa = lC2
                            Case "actual arr time"
                                lCAT = lC2
                            Case "facility"
                                lCLa = lC2
                            Case "wagons"
                                lCWa = lC2
                                
                        End Select
                    Next lC2
                    Exit For
                End If
            Next lC
            If lRHa Then Exit For   'header row found in array, don't loop any further
        Next lRa
        For lRd = 1 To UBd1
            For lC = 1 To UBd2
                If LCase(vDep(lRd, lC)) Like "operator" Then
                    lRHd = lRd
                    lCOd = lC
                    For lC2 = 1 To UBd2
                        Select Case LCase(vDep(lRHd, lC2))      '<<< the column headers (lower case). _
                                                if these change, the names below need to be adjusted
                            Case "commodity"
                                lCPd = lC2
                            Case "id"
                                lCIDd = lC2
                            Case "actual dep time"
                                lCDT = lC2
                                
                        End Select
                    Next lC2
                    Exit For
                End If
            Next lC
            If lRHd Then Exit For   'header row found in array
        Next lRd
        
        dtArriv = DateValue(vArriv(lRHa - 1, 15)) '15th column, one row up from header row. This equates to column O <<< modify 15 if different column
        
        
        ' now filter the arrival array on operator and product
        For lRa = lRHa + 1 To UBa1
            If (LCase(vArriv(lRa, lCOa)) Like sOperator) And (LCase(vArriv(lRa, lCPa)) Like sProduct) Then
                'operator and product found. Copy to output array
                lRo = lRo + 1   'to next row of output array
                vOut(lRo, 1) = dtArriv
                vOut(lRo, 2) = vArriv(lRa, lCOa)
                vOut(lRo, 3) = vArriv(lRa, lCWa)
                vOut(lRo, 4) = vArriv(lRa, lCLa)
                vOut(lRo, 5) = vArriv(lRa, lCIDa)
                vOut(lRo, 6) = vArriv(lRa, lCAT)
                
                'find related entry in Departures
                For lRd = 1 To UBd1 'loop through rows in Departures array
                    If vArriv(lRa, lCIDa) = vDep(lRd, lCIDd) And _
                            vArriv(lRa, lCAT) < vDep(lRd, lCDT) And _
                            IsEmpty(vDep(lRd, UBd2)) Then 'Same ID and departure time > arrival time, and not processed earlier
                        vOut(lRo, 7) = vDep(lRa, lCIDd)
                        vOut(lRo, 8) = vDep(lRa, lCDT)
                        
                        'mark row as processed
                        vDep(lRd, UBd2) = True
                        'stop searching
                        Exit For
                    End If
                Next lRd
            End If
        Next lRa
        
        'dump output array to Staged Wagons sheet
        lRSW = shOut.Cells(shOut.Rows.Count, 1).End(xlUp).Row + 1
        shOut.Cells(lRSW, 1).Resize(UBa1 + UBd1, 8).Value = vOut
        
        'check departures for any unprocessed lines for this operator/product
        ReDim vUnprocessed(1 To UBd1, 1 To 2)
        vUnprocessed(1, 1) = MyFiles & "unprocessed departures for this operator / product:"
        vUnprocessed(2, 1) = "-none-"
        lRe = 2
        'find unprocessed entry in Departures
        For lRd = 1 To UBd1
            If (vDep(lRd, lCOd) Like sOperator) And (vDep(lRd, lCPd) Like sProduct) And _
                    IsEmpty(vDep(lRd, UBd2)) Then 'Same operator / product, but not processed
                vUnprocessed(lRe, 1) = vDep(lRd, lCIDd)
                vUnprocessed(lRe, 2) = vDep(lRa, lCDT)
                lRe = lRe + 1
            End If
        Next lRd
        'dump this info to output sheet, next to output
        shOut.Cells(lRSW, 10).Resize(UBd1, 2).Value = vUnprocessed
NextFile:
        MyFiles = Dir
    Loop
End Sub

 

[bedsy]

Hi Sijpie.........Wow, some complex code.

I keep getting "subscript out of range" error.

Happens directly after I input which operator and product, seems to open the first selected sheet and then I get the Error.

Any thoughts?

 

[bedsy]

Hi Sijpie.........Wow, some complex code.

I keep getting "subscript out of range" error.

Happens directly after I input which operator and product, seems to open the first selected sheet and then I get the Error.

Any thoughts?

Another update.

I isolated it to search through a single workbook only and now is showing a "Type Mismatch".

everything is the same as the initial test (develops new sheet with correct headers but as soon as I enter the items to filter and hit enter is does a quick update and returns the error).
No data is transferred to the staged wagons sheet

Find attached sample sheet for your reference.

Arrivals Sheet

ARRIVALS: 0001 hours - 2359 hours															1.05.2023
Operator	Commodity	ID	Facility	Unit	Actual Unit	Tonnage	Wagons	Planned Arr Time	Actual Arr Time	Mins Late	Planned Unload Time	Complete Unload Time	Actual Start Unload Time	Complete Unload Time	Comments
TL	BULK	9111	GC				33		0320

Departure Sheet

DEPARTURES: 0001 hours - 2359 hours									1.05.2023
Operator	Commodity	ID	Wgns	Planned Unit No	Actual Unit No	Planned Dep Time	Actual Dep Time	Mins Late	Comments
TL	BULK	9111	33				0500

 

[sijpie]

Your date format is 05.10.2023
What happens when you change that to 05/10/2023?
Let me know, I can then modify to capture that error.

Also, when an error occurs, press the Debug button, and let me know the line with the error (highlighted yellow)

 

[bedsy]

Your date format is 05.10.2023
What happens when you change that to 05/10/2023?
Let me know, I can then modify to capture that error.

Also, when an error occurs, press the Debug button, and let me know the line with the error (highlighted yellow)

Update the date formatting..... run code and receive runtime error 13 - type mismatch.

when hitting debug nothing shows.
Stepping through the code, all seems fine until I hit OK after typing in the product/commodity filter but again no highlighted line in the code.

 

[sijpie]

I think I resolved the problem when you got the 'subscript out of range' problem.
i don't know what caused the error when you restricted it to one file.

Anyway, try this (with multiple files)

Sub OpenBooksNew()
'// Macro that opens each workbook in selected dir and then lists the arrivals and _
 // departures of consignments for selected Operator and Product. _
 // Any departures that cannot be matched with arrival are seperatly listed for _
 // manual processing
 
    'arrays are used for fast processing of data
    Dim vArriv As Variant, vDep As Variant, vOut As Variant, vUnprocessed As Variant
    Dim lRa As Long, lRd As Long, lRo As Long, lC As Long, lC2 As Long, lRHa As Long, lRHd As Long, _
        UBa1 As Long, UBd1 As Long, UB1o As Long, UBa2 As Long, UBd2 As Long, lRSW As Long, _
        lCOa As Long, lCPa As Long, lCIDa As Long, lCLa As Long, lCWa As Long, _
        lCAT As Long, lCOd As Long, lCPd As Long, lCIDd As Long, lCDT As Long, lRe As Long
    Dim sPath As String, MyFiles As String
    Dim shArr As Worksheet, shDep As Worksheet, shOut As Worksheet
    Dim wbInput As Workbook
    Dim sOperator As String, sProduct As String
    Dim rFind As Range
    Dim dtArriv As String, dtDep As String
    
    Application.ScreenUpdating = False
    
    'check for output sheet
    For Each shOut In ThisWorkbook.Sheets
        If LCase(shOut.Name) Like "staged wagons" Then
            Exit For
        End If
    Next shOut
    If shOut Is Nothing Then        'sheet not found, so create
        ThisWorkbook.Sheets.Add
        Set shOut = ActiveSheet
        shOut.Name = "Staged Wagons"
    End If
    shOut.Range("A1").CurrentRegion.ClearContents       '<<< Comment out this line to add current filtered data to existing sheet
    lRSW = shOut.Cells(shOut.Rows.Count, 1).End(xlUp).Row
    If lRSW = 1 Then     'add headings to output sheet
        ReDim vOut(1 To 1, 1 To 8)
        vOut(1, 1) = "Date"
        vOut(1, 2) = "Operator"
        vOut(1, 3) = "Wagons"
        vOut(1, 4) = "Location"
        vOut(1, 5) = "Arriv ID"
        vOut(1, 6) = "Arriv Time"
        vOut(1, 7) = "Dep ID"
        vOut(1, 8) = "Dep Time"
        shOut.Range("A1").Resize(1, 8).Value = vOut
    End If
    
    ' select folder where input sheet sit
    With Application.FileDialog(msoFileDialogFolderPicker)
      .Title = "Select Folder"
      If .Show <> -1 Then Exit Sub      'user cancelled
      sPath = .SelectedItems(1) & "\"
    End With
    
    'Get the Operator and Product to filter on <<< this can also be achieved in other ways, but for now a simple inputbox
    sOperator = InputBox("Which operator is to be filtered on?", "Filter on Operator")
    If Len(sOperator) = 0 Then Exit Sub
    sOperator = LCase(sOperator)
    sProduct = InputBox("Which Product/ Commodity is to be filtered on?", "Filter on Product")
    If Len(sProduct) = 0 Then Exit Sub
    sProduct = LCase(sProduct)
    
    'Find the first input file in the selected folder
    MyFiles = Dir(sPath & "*.xlsx")
    'for each file in the folder
    Do While MyFiles <> ""
        'open input file
        Set wbInput = Workbooks.Open(sPath & MyFiles)
        'find Arrivals and Departures sheets
        For Each shArr In wbInput.Sheets
            If shArr.Name Like "Arrivals" Then
                Exit For
            End If
        Next shArr
        For Each shDep In wbInput.Sheets
            If shDep.Name Like "Departures" Then
                Exit For
            End If
        Next shDep
        If shArr Is Nothing Or shDep Is Nothing Then
            GoTo NextFile       'the workbook does not have the required input sheets
        End If
        
        'find the start of the database
        Set rFind = shArr.Cells.Find("Operator")
        If rFind Is Nothing Then GoTo NextFile
        'fill the Arrival array with the database
        vArriv = rFind.CurrentRegion.Value
        'find the start of the database
        Set rFind = shDep.Cells.Find("Operator")
        If rFind Is Nothing Then GoTo NextFile
        'fill the departure array with the database, add one extra column
        With rFind
            vDep = .Resize(.CurrentRegion.Rows.Count, .CurrentRegion.Columns.Count + 1).Value
        End With
        
        'close the input workbook
        wbInput.Close SaveChanges:=False
        
        'store number of rows in each array
        UBa1 = UBound(vArriv, 1)
        UBd1 = UBound(vDep, 1)
        'store number of columns in each array
        UBa2 = UBound(vArriv, 2)
        UBd2 = UBound(vDep, 2)
        
        'Size the output array
        ReDim vOut(1 To UBa1 + UBd1, 1 To 8) 'output array - set to maximum posible rows
        lRo = 0
        
        'get header row and relevant columns for each of the input arrays. _
         This is in case the column order is changed by a user
        For lRa = 1 To UBa1
            For lC = 1 To UBa2
                If LCase(vArriv(lRa, lC)) Like "operator" Then
                    lRHa = lRa
                    lCOa = lC
                    For lC2 = 1 To UBa2
                        Select Case LCase(vArriv(lRHa, lC2))    '<<< the column headers (lower case). _
                                                if these change, the names below need to be adjusted
                            Case "commodity"
                                lCPa = lC2
                            Case "id"
                                lCIDa = lC2
                            Case "actual arr time"
                                lCAT = lC2
                            Case "facility"
                                lCLa = lC2
                            Case "wagons"
                                lCWa = lC2
                                
                        End Select
                    Next lC2
                    Exit For
                End If
            Next lC
            If lRHa Then Exit For   'header row found in array, don't loop any further
        Next lRa
        For lRd = 1 To UBd1
            For lC = 1 To UBd2
                If LCase(vDep(lRd, lC)) Like "operator" Then
                    lRHd = lRd
                    lCOd = lC
                    For lC2 = 1 To UBd2
                        Select Case LCase(vDep(lRHd, lC2))      '<<< the column headers (lower case). _
                                                if these change, the names below need to be adjusted
                            Case "commodity"
                                lCPd = lC2
                            Case "id"
                                lCIDd = lC2
                            Case "actual dep time"
                                lCDT = lC2
                                
                        End Select
                    Next lC2
                    Exit For
                End If
            Next lC
            If lRHd Then Exit For   'header row found in array
        Next lRd
        
        dtArriv = vArriv(lRHa - 1, 15) '15th column, one row up from header row. This equates to column O <<< modify 15 if different column
        
        
        ' now filter the arrival array on operator and product
        For lRa = lRHa + 1 To UBa1
            If (LCase(vArriv(lRa, lCOa)) Like sOperator) And (LCase(vArriv(lRa, lCPa)) Like sProduct) Then
                'operator and product found. Copy to output array
                lRo = lRo + 1   'to next row of output array
                vOut(lRo, 1) = dtArriv
                vOut(lRo, 2) = vArriv(lRa, lCOa)
                vOut(lRo, 3) = vArriv(lRa, lCWa)
                vOut(lRo, 4) = vArriv(lRa, lCLa)
                vOut(lRo, 5) = vArriv(lRa, lCIDa)
                vOut(lRo, 6) = vArriv(lRa, lCAT)
                
                'find related entry in Departures
                For lRd = 2 To UBd1 'loop through rows in Departures array
                    If vArriv(lRa, lCIDa) = vDep(lRd, lCIDd) And _
                            CInt(vArriv(lRa, lCAT)) < CInt(vDep(lRd, lCDT)) And _
                            IsEmpty(vDep(lRd, UBd2)) Then 'Same ID and departure time > arrival time, and not processed earlier
                        vOut(lRo, 7) = vDep(lRa, lCIDd)
                        vOut(lRo, 8) = vDep(lRa, lCDT)
                        
                        'mark row as processed
                        vDep(lRd, UBd2) = True
                        'stop searching
                        Exit For
                    End If
                Next lRd
            End If
        Next lRa
        
        'dump output array to Staged Wagons sheet
        lRSW = shOut.Cells(shOut.Rows.Count, 1).End(xlUp).Row + 1
        shOut.Cells(lRSW, 1).Resize(UBa1 + UBd1, 8).Value = vOut
        
        'check departures for any unprocessed lines for this operator/product
        ReDim vUnprocessed(1 To UBd1, 1 To 2)
        vUnprocessed(1, 1) = MyFiles & "unprocessed departures for this operator / product:"
        vUnprocessed(2, 1) = "-none-"
        lRe = 2
        'find unprocessed entry in Departures
        For lRd = 1 To UBd1
            If (vDep(lRd, lCOd) Like sOperator) And (vDep(lRd, lCPd) Like sProduct) And _
                    IsEmpty(vDep(lRd, UBd2)) Then 'Same operator / product, but not processed
                vUnprocessed(lRe, 1) = vDep(lRd, lCIDd)
                vUnprocessed(lRe, 2) = vDep(lRa, lCDT)
                lRe = lRe + 1
            End If
        Next lRd
        'dump this info to output sheet, next to output
        shOut.Cells(lRSW, 10).Resize(UBd1, 2).Value = vUnprocessed
NextFile:
        MyFiles = Dir
    Loop
End Sub

 

[bedsy]

I think I resolved the problem when you got the 'subscript out of range' problem.
i don't know what caused the error when you restricted it to one file.

Anyway, try this (with multiple files)

Sub OpenBooksNew()
'// Macro that opens each workbook in selected dir and then lists the arrivals and _
 // departures of consignments for selected Operator and Product. _
 // Any departures that cannot be matched with arrival are seperatly listed for _
 // manual processing
 
    'arrays are used for fast processing of data
    Dim vArriv As Variant, vDep As Variant, vOut As Variant, vUnprocessed As Variant
    Dim lRa As Long, lRd As Long, lRo As Long, lC As Long, lC2 As Long, lRHa As Long, lRHd As Long, _
        UBa1 As Long, UBd1 As Long, UB1o As Long, UBa2 As Long, UBd2 As Long, lRSW As Long, _
        lCOa As Long, lCPa As Long, lCIDa As Long, lCLa As Long, lCWa As Long, _
        lCAT As Long, lCOd As Long, lCPd As Long, lCIDd As Long, lCDT As Long, lRe As Long
    Dim sPath As String, MyFiles As String
    Dim shArr As Worksheet, shDep As Worksheet, shOut As Worksheet
    Dim wbInput As Workbook
    Dim sOperator As String, sProduct As String
    Dim rFind As Range
    Dim dtArriv As String, dtDep As String
   
    Application.ScreenUpdating = False
   
    'check for output sheet
    For Each shOut In ThisWorkbook.Sheets
        If LCase(shOut.Name) Like "staged wagons" Then
            Exit For
        End If
    Next shOut
    If shOut Is Nothing Then        'sheet not found, so create
        ThisWorkbook.Sheets.Add
        Set shOut = ActiveSheet
        shOut.Name = "Staged Wagons"
    End If
    shOut.Range("A1").CurrentRegion.ClearContents       '<<< Comment out this line to add current filtered data to existing sheet
    lRSW = shOut.Cells(shOut.Rows.Count, 1).End(xlUp).Row
    If lRSW = 1 Then     'add headings to output sheet
        ReDim vOut(1 To 1, 1 To 8)
        vOut(1, 1) = "Date"
        vOut(1, 2) = "Operator"
        vOut(1, 3) = "Wagons"
        vOut(1, 4) = "Location"
        vOut(1, 5) = "Arriv ID"
        vOut(1, 6) = "Arriv Time"
        vOut(1, 7) = "Dep ID"
        vOut(1, 8) = "Dep Time"
        shOut.Range("A1").Resize(1, 8).Value = vOut
    End If
   
    ' select folder where input sheet sit
    With Application.FileDialog(msoFileDialogFolderPicker)
      .Title = "Select Folder"
      If .Show <> -1 Then Exit Sub      'user cancelled
      sPath = .SelectedItems(1) & "\"
    End With
   
    'Get the Operator and Product to filter on <<< this can also be achieved in other ways, but for now a simple inputbox
    sOperator = InputBox("Which operator is to be filtered on?", "Filter on Operator")
    If Len(sOperator) = 0 Then Exit Sub
    sOperator = LCase(sOperator)
    sProduct = InputBox("Which Product/ Commodity is to be filtered on?", "Filter on Product")
    If Len(sProduct) = 0 Then Exit Sub
    sProduct = LCase(sProduct)
   
    'Find the first input file in the selected folder
    MyFiles = Dir(sPath & "*.xlsx")
    'for each file in the folder
    Do While MyFiles <> ""
        'open input file
        Set wbInput = Workbooks.Open(sPath & MyFiles)
        'find Arrivals and Departures sheets
        For Each shArr In wbInput.Sheets
            If shArr.Name Like "Arrivals" Then
                Exit For
            End If
        Next shArr
        For Each shDep In wbInput.Sheets
            If shDep.Name Like "Departures" Then
                Exit For
            End If
        Next shDep
        If shArr Is Nothing Or shDep Is Nothing Then
            GoTo NextFile       'the workbook does not have the required input sheets
        End If
       
        'find the start of the database
        Set rFind = shArr.Cells.Find("Operator")
        If rFind Is Nothing Then GoTo NextFile
        'fill the Arrival array with the database
        vArriv = rFind.CurrentRegion.Value
        'find the start of the database
        Set rFind = shDep.Cells.Find("Operator")
        If rFind Is Nothing Then GoTo NextFile
        'fill the departure array with the database, add one extra column
        With rFind
            vDep = .Resize(.CurrentRegion.Rows.Count, .CurrentRegion.Columns.Count + 1).Value
        End With
       
        'close the input workbook
        wbInput.Close SaveChanges:=False
       
        'store number of rows in each array
        UBa1 = UBound(vArriv, 1)
        UBd1 = UBound(vDep, 1)
        'store number of columns in each array
        UBa2 = UBound(vArriv, 2)
        UBd2 = UBound(vDep, 2)
       
        'Size the output array
        ReDim vOut(1 To UBa1 + UBd1, 1 To 8) 'output array - set to maximum posible rows
        lRo = 0
       
        'get header row and relevant columns for each of the input arrays. _
         This is in case the column order is changed by a user
        For lRa = 1 To UBa1
            For lC = 1 To UBa2
                If LCase(vArriv(lRa, lC)) Like "operator" Then
                    lRHa = lRa
                    lCOa = lC
                    For lC2 = 1 To UBa2
                        Select Case LCase(vArriv(lRHa, lC2))    '<<< the column headers (lower case). _
                                                if these change, the names below need to be adjusted
                            Case "commodity"
                                lCPa = lC2
                            Case "id"
                                lCIDa = lC2
                            Case "actual arr time"
                                lCAT = lC2
                            Case "facility"
                                lCLa = lC2
                            Case "wagons"
                                lCWa = lC2
                               
                        End Select
                    Next lC2
                    Exit For
                End If
            Next lC
            If lRHa Then Exit For   'header row found in array, don't loop any further
        Next lRa
        For lRd = 1 To UBd1
            For lC = 1 To UBd2
                If LCase(vDep(lRd, lC)) Like "operator" Then
                    lRHd = lRd
                    lCOd = lC
                    For lC2 = 1 To UBd2
                        Select Case LCase(vDep(lRHd, lC2))      '<<< the column headers (lower case). _
                                                if these change, the names below need to be adjusted
                            Case "commodity"
                                lCPd = lC2
                            Case "id"
                                lCIDd = lC2
                            Case "actual dep time"
                                lCDT = lC2
                               
                        End Select
                    Next lC2
                    Exit For
                End If
            Next lC
            If lRHd Then Exit For   'header row found in array
        Next lRd
       
        dtArriv = vArriv(lRHa - 1, 15) '15th column, one row up from header row. This equates to column O <<< modify 15 if different column
       
       
        ' now filter the arrival array on operator and product
        For lRa = lRHa + 1 To UBa1
            If (LCase(vArriv(lRa, lCOa)) Like sOperator) And (LCase(vArriv(lRa, lCPa)) Like sProduct) Then
                'operator and product found. Copy to output array
                lRo = lRo + 1   'to next row of output array
                vOut(lRo, 1) = dtArriv
                vOut(lRo, 2) = vArriv(lRa, lCOa)
                vOut(lRo, 3) = vArriv(lRa, lCWa)
                vOut(lRo, 4) = vArriv(lRa, lCLa)
                vOut(lRo, 5) = vArriv(lRa, lCIDa)
                vOut(lRo, 6) = vArriv(lRa, lCAT)
               
                'find related entry in Departures
                For lRd = 2 To UBd1 'loop through rows in Departures array
                    If vArriv(lRa, lCIDa) = vDep(lRd, lCIDd) And _
                            CInt(vArriv(lRa, lCAT)) < CInt(vDep(lRd, lCDT)) And _
                            IsEmpty(vDep(lRd, UBd2)) Then 'Same ID and departure time > arrival time, and not processed earlier
                        vOut(lRo, 7) = vDep(lRa, lCIDd)
                        vOut(lRo, 8) = vDep(lRa, lCDT)
                       
                        'mark row as processed
                        vDep(lRd, UBd2) = True
                        'stop searching
                        Exit For
                    End If
                Next lRd
            End If
        Next lRa
       
        'dump output array to Staged Wagons sheet
        lRSW = shOut.Cells(shOut.Rows.Count, 1).End(xlUp).Row + 1
        shOut.Cells(lRSW, 1).Resize(UBa1 + UBd1, 8).Value = vOut
       
        'check departures for any unprocessed lines for this operator/product
        ReDim vUnprocessed(1 To UBd1, 1 To 2)
        vUnprocessed(1, 1) = MyFiles & "unprocessed departures for this operator / product:"
        vUnprocessed(2, 1) = "-none-"
        lRe = 2
        'find unprocessed entry in Departures
        For lRd = 1 To UBd1
            If (vDep(lRd, lCOd) Like sOperator) And (vDep(lRd, lCPd) Like sProduct) And _
                    IsEmpty(vDep(lRd, UBd2)) Then 'Same operator / product, but not processed
                vUnprocessed(lRe, 1) = vDep(lRd, lCIDd)
                vUnprocessed(lRe, 2) = vDep(lRa, lCDT)
                lRe = lRe + 1
            End If
        Next lRd
        'dump this info to output sheet, next to output
        shOut.Cells(lRSW, 10).Resize(UBd1, 2).Value = vUnprocessed
NextFile:
        MyFiles = Dir
    Loop
End Sub

Hi sijpie,

I have run the new code with mixed results.
I originally ran with multiple files and received "run time error '9' - subscript out of range. I have then ran the code using my single isolated sheet which did have some success.
The arrivals detail was carried over successfully but the departure details or the date were not. the note you have added for unprocessed details returned 'none'.
I have then pulled out a single spreadsheet from the folder with multiples and ran that individual file with the code but returned the same run time error as when I first tried with the whole folder.

I'm so confused......

 

[sijpie]

The input workbooks have an arrivals and a departure sheet with headings as follows:

Bulk Terminal Report
ARRIVALS: 0001 hours - 2359 hours															04/05/23
Rail Operator	Commodity	Train ID.	Discharge Facility	Planned Unit No	Actual Unit No	No. Wgns	Tonnage	Planned Arr Time	Actual Arr Time	Mins Late	Planned Unload Time	Complete Unload Time	Actual Start Unload Time	Complete Unload Time	Comments
Op1	Coal	TM94	ABC	52	52	45	4500	0318	0257	OK	0330	0440	0310	0418

Bulk Terminal Report
DEPARTURES: 0001 hours - 2359 hours									04/05/23
Rail Operator	Commodity	Train ID	No. Wgns	Planned Unit No	Actual Unit No	Planned Dep Time	Actual Dep Time	Mins Late	Comments
Op1	COAL	TM71	45	52	52	0522	0527	OK

The macro below will create the following output (formatting is manual):

Operator: Op1			Product: bulk
Date	Rail Operator	No. Wgns (A)	Discharge Facility	Arriv ID	Actual Arr Time	Dep ID	No. Wgns (D)	Actual Dep Time	-	Unprocessed departures for this operator / product:
05/01/2023	Op1	24	0	9837	1200	9837	48	1706		01.05.2023.xlsx
05/03/2023	Op2	50	NA	9839	159	9839	50	408		-none-
05/03/2023	Op3	50	NA	5938	434	5938	50	732		02.05.2023.xlsx
05/03/2023	Op4	30	NA	9339	1502	9339	30	1740		-none-
05/05/2023	Op5	50	NIL	9537	203	9537	50	530		03.05.2023.xlsx

Option Explicit


Sub OpenBooksNew()
'// Macro that opens each workbook in selected dir and then lists the arrivals and _
 // departures of consignments for selected Operator and Product. _
 // Any departures that cannot be matched with arrival are seperatly listed for _
 // manual processing
 
    'arrays are used for fast processing of data
    Dim vArriv As Variant, vDep As Variant, vOut As Variant, vUnprocessed As Variant
    Dim lRa As Long, lRd As Long, lRo As Long, lC As Long, lC2 As Long, lRHa As Long, lRHd As Long, _
        UBa1 As Long, UBd1 As Long, UB1o As Long, UB2o As Long, UBa2 As Long, UBd2 As Long, lRSW As Long, _
        lCOa As Long, lCPa As Long, lCIDa As Long, lCLa As Long, lCWa As Long, lCWd As Long, _
        lCAT As Long, lCOd As Long, lCPd As Long, lCIDd As Long, lCDT As Long, lRe As Long, lCCom As Long
    Dim sPath As String, MyFiles As String
    Dim shArr As Worksheet, shDep As Worksheet, shOut As Worksheet
    Dim wbInput As Workbook
    Dim sOperator As String, sProduct As String
    Dim rFind As Range
    Dim dtArriv As String, dtDep As String
    
    '<<<<<<!!!!!!! The constants below need to exaclty reflect your headings in Arrivals / Departures sheets.
                    
    Const sHEAD_ROp As String = "Rail Operator", sHEAD_Com As String = "Commodity", _
          sHEAD_TIDa As String = "Train ID.", sHEAD_DFac As String = "Discharge Facility", _
          sHEAD_Wg As String = "No. Wgns", sHEAD_TIDd As String = "Train ID", _
          sHEAD_AATm As String = "Actual Arr Time", sHEAD_ADTm As String = "Actual Dep Time", _
          sHEAD_Comment As String = "Comments"
          
          
    Application.ScreenUpdating = False
    
    'Get the Operator and Product to filter on <<< this can also be achieved in other ways, but for now a simple inputbox
    sOperator = InputBox("Which operator is to be filtered on?", "Filter on Operator")
    If Len(sOperator) = 0 Then Exit Sub
    sOperator = LCase(sOperator)
    sProduct = InputBox("Which Product/ Commodity is to be filtered on?", "Filter on Product")
    If Len(sProduct) = 0 Then Exit Sub
    sProduct = LCase(sProduct)
    
    'check for output sheet
    For Each shOut In ThisWorkbook.Sheets
        If LCase(shOut.Name) Like "staged wagons" Then
            Exit For
        End If
    Next shOut
    If shOut Is Nothing Then        'sheet not found, so create
        ThisWorkbook.Sheets.Add
        Set shOut = ActiveSheet
        shOut.Name = "Staged Wagons"
    End If
    shOut.Range("A1").CurrentRegion.ClearContents       '<<< Comment out this line to add current filtered data to existing sheet
    
    lRSW = shOut.Cells(shOut.Rows.Count, 1).End(xlUp).Row
    If lRSW = 1 Then     'add headings to output sheet
        ReDim vOut(1 To 2, 1 To 11)
        vOut(1, 1) = "Operator: " & sOperator
        vOut(1, 4) = "Product: " & sProduct
        vOut(2, 1) = "Date"
        vOut(2, 2) = sHEAD_ROp
        vOut(2, 3) = sHEAD_Wg & " (A)"
        vOut(2, 4) = sHEAD_DFac
        vOut(2, 5) = "Arriv ID"
        vOut(2, 6) = sHEAD_AATm
        vOut(2, 7) = "Dep ID"
        vOut(2, 8) = sHEAD_Wg & " (D)"
        vOut(2, 9) = sHEAD_ADTm
        vOut(2, 10) = "  -  "
        vOut(2, 11) = "Unprocessed departures for this operator / product:"
        shOut.Range("A1").Resize(2, UBound(vOut, 2)).Value = vOut
    End If
    
    ' select folder where input workbooks sit
    With Application.FileDialog(msoFileDialogFolderPicker)
      .Title = "Select Folder"
      If .Show <> -1 Then Exit Sub      'user cancelled
      sPath = .SelectedItems(1) & "\"
    End With
    
    'Find the first input file in the selected folder
    MyFiles = Dir(sPath & "*.xlsx")
    'for each file in the folder
    Do While MyFiles <> ""
        'open input file
        Set wbInput = Workbooks.Open(sPath & MyFiles)
        'find Arrivals and Departures sheets
        For Each shArr In wbInput.Sheets
            If shArr.Name Like "Arrivals" Then
                Exit For
            End If
        Next shArr
        For Each shDep In wbInput.Sheets
            If shDep.Name Like "Departures" Then
                Exit For
            End If
        Next shDep
        If shArr Is Nothing Or shDep Is Nothing Then
            GoTo NextFile       'the workbook does not have the required input sheets
        End If
        
        'find the start of the database
        Set rFind = shArr.Cells.Find("Operator")
        If rFind Is Nothing Then GoTo NextFile
        'fill the Arrival array with the database
        vArriv = rFind.CurrentRegion.Value
        'find the start of the database
        Set rFind = shDep.Cells.Find("Operator")
        If rFind Is Nothing Then GoTo NextFile
        'fill the departure array with the database, add one extra column
        With rFind
            vDep = .Resize(.CurrentRegion.Rows.Count, .CurrentRegion.Columns.Count + 1).Value
        End With
        
        'close the input workbook
        wbInput.Close SaveChanges:=False
        
        'store number of rows in each array
        UBa1 = UBound(vArriv, 1)
        UBd1 = UBound(vDep, 1)
        'store number of columns in each array
        UBa2 = UBound(vArriv, 2)
        UBd2 = UBound(vDep, 2)
        
        'Size the output array
        ReDim vOut(1 To UBa1 + UBd1, 1 To 9) 'output array - set to maximum posible rows
        lRo = 0
        UB1o = UBound(vOut, 1)
        UB2o = UBound(vOut, 2)
        'get header row and relevant columns for each of the input arrays. _
         This is in case the column order is changed by a user
        For lRa = 1 To UBa1
            For lC = 1 To UBa2
                If vArriv(lRa, lC) Like sHEAD_ROp Then
                    lRHa = lRa
                    lCOa = lC
                    For lC2 = 1 To UBa2
                        Select Case vArriv(lRHa, lC2)
                            Case sHEAD_Com
                                lCPa = lC2
                            Case sHEAD_TIDa
                                lCIDa = lC2
                            Case sHEAD_AATm
                                lCAT = lC2
                            Case sHEAD_DFac
                                lCLa = lC2
                            Case sHEAD_Wg
                                lCWa = lC2
                            Case sHEAD_Comment
                                lCCom = lC2
                                
                        End Select
                    Next lC2
                    Exit For
                End If
            Next lC
            If lRHa Then Exit For   'header row found in array, don't loop any further
        Next lRa
        For lRd = 1 To UBd1
            For lC = 1 To UBd2
                If vDep(lRd, lC) Like sHEAD_ROp Then
                    lRHd = lRd
                    lCOd = lC
                    For lC2 = 1 To UBd2
                        Select Case vDep(lRHd, lC2)
                            Case sHEAD_Com
                                lCPd = lC2
                            Case sHEAD_TIDd
                                lCIDd = lC2
                            Case sHEAD_ADTm
                                lCDT = lC2
                            Case sHEAD_Wg
                                lCWd = lC2
                        End Select
                    Next lC2
                    Exit For
                End If
            Next lC
            If lRHd Then Exit For   'header row found in array
        Next lRd
        
        dtArriv = vArriv(lRHa - 1, lCCom) 'Same column as Comments, one row up from header row.
        
        
        ' now filter the arrival array on operator and product
        For lRa = lRHa + 1 To UBa1
            If (LCase(vArriv(lRa, lCOa)) Like sOperator) And (LCase(vArriv(lRa, lCPa)) Like sProduct) Then
                'operator and product found. Copy to output array
                lRo = lRo + 1   'to next row of output array
                vOut(lRo, 1) = dtArriv
                vOut(lRo, 2) = vArriv(lRa, lCOa)
                vOut(lRo, 3) = vArriv(lRa, lCWa)
                vOut(lRo, 4) = vArriv(lRa, lCLa)
                vOut(lRo, 5) = vArriv(lRa, lCIDa)
                vOut(lRo, 6) = vArriv(lRa, lCAT)
                
                'find related entry in Departures
                For lRd = 2 To UBd1 'loop through rows in Departures array
                    If vArriv(lRa, lCIDa) = vDep(lRd, lCIDd) And _
                            CInt(vArriv(lRa, lCAT)) < CInt(vDep(lRd, lCDT)) And _
                            IsEmpty(vDep(lRd, UBd2)) Then 'Same ID and departure time > arrival time, and not processed earlier
                        vOut(lRo, 7) = vDep(lRd, lCIDd)
                        vOut(lRo, 8) = vDep(lRd, lCWd)
                        vOut(lRo, 9) = vDep(lRd, lCDT)
                        
                        'mark row as processed
                        vDep(lRd, UBd2) = True
                        'stop searching
                        Exit For
                    End If
                Next lRd
            End If
        Next lRa
        
        'dump output array to Staged Wagons sheet
        lRSW = shOut.Cells(shOut.Rows.Count, 1).End(xlUp).Row + 1
        shOut.Cells(lRSW, 1).Resize(UB1o, UB2o).Value = vOut
        
        'check departures for any unprocessed lines for this operator/product
        ReDim vUnprocessed(1 To UBd1, 1 To 2)
        vUnprocessed(1, 1) = MyFiles
        vUnprocessed(2, 1) = "-none-"
        lRe = 2
        'find unprocessed entry in Departures
        For lRd = 1 To UBd1
            If (LCase(vDep(lRd, lCOd)) Like sOperator) And (LCase(vDep(lRd, lCPd)) Like sProduct) And _
                    IsEmpty(vDep(lRd, UBd2)) Then 'Same operator / product, but not processed
                vUnprocessed(lRe, 1) = vDep(lRd, lCIDd)
                vUnprocessed(lRe, 2) = vDep(lRd, lCDT)
                lRe = lRe + 1
            End If
        Next lRd
        'dump this info to output sheet, next to output
        shOut.Cells(WorksheetFunction.Max(lRSW, shOut.Cells(shOut.Rows.Count, UB2o + 2).End(xlUp).Row + 1), UB2o + 2).Resize(UBd1, 2).Value = vUnprocessed
NextFile:
        MyFiles = Dir
    Loop
End Sub