VBA Excel conditional based calculations on values that vary from each other

Question

I have a folder with many workbooks, which are pretty much the same layout. They include most of the codes as well as similar values, which you can see in column H. Let's have a look at the example below: I have the values falling under the code of 1682, within which I might have the Uplift code 1128U, 1126U, or other or simply empty value. I need to calculate all the values belonging to the given code (column A) and uplift the code (column H) at once. These values will come from all the workbooks in the given directory. The values, you can see here are just from one workbook. I have another 45 workbooks with other values than seen in the screen below and I would like to sum them up. How can I do it with the code below?

where in the H column are different values assigned to the code in column A.

I would like to have the correct sums calculated for the particular values in column H, which fall within the code as shown in column A. These values in column H might repeat across other codes in column A, as you see below in the case of codes 1687 and 4032 but they must represent individual records.

The problem is, that the simple condition, shown below:

 Sub SearchFolders_Cables()

 Dim wbAct As Workbook, pathMainWb As String, fldrPath As String
 Dim BOM As String, scrUpdt, WsOut As Worksheet, colFiles As Collection, f As Object
Dim xBol As Boolean, wb As Workbook, ws As Worksheet, arrWs
Dim matchedCells As Collection, Cell, numHits As Long, summRow As Long

Set WsCalc = Workbooks("BoM calculator v4.1G.xlsm")


Set wbAct = ActiveWorkbook
pathMainWb = wbAct.FullName '<<<<

On Error GoTo ErrHandler

fldrPath = UserSelectFolder("Select a folder")
If Len(fldrPath) = 0 Then Exit Sub

'get all files in the selected folder
Set colFiles = GetFileMatches(fldrPath, "*.xls*", False) 'False=no subfolders
If colFiles.Count = 0 Then
    MsgBox "No Excel files found in selected folder"
    Exit Sub
End If
'///////////////////////////CALCULATION EACH CODE FROM ALL FILES IN DIRECTORY/////////////////////////////
lRow = Cells(Rows.Count, 1).End(xlUp).Row
For Each iCell In Range("A2:A" & lRow).Cells
'-----------------------------------CASE 1----------------------------------------
    If iCell.EntireRow.Range("H1").Value = "" Then
        'BOM = InputBox("The current BoM Code is...", "BoM Calculator v1.1", (iCell.Value))
        BOM = iCell.Value
        scrUpdt = Application.ScreenUpdating
        Application.ScreenUpdating = False

        Set WsOut = ThisWorkbook.Worksheets("SUMMARY")
        WsOut.UsedRange.Delete  'Clearing out previous records (very important!!!)

        summRow = 1
        'sheet names to scan
        arrWs = Array("Cable Work Order")
        WsOut.Cells(summRow, 1).Resize(1, 6).Value = Array("Workbook", "Worksheet", _
                        "Cell", "Text in Cell", "Values corresponding", "Uplift Code")
        For Each f In colFiles
            xBol = (f.Path = pathMainWb)  'file already open?
            If xBol Then
                Set wb = wbAct
            Else
                Set wb = Workbooks.Open(FileName:=f.Path, UpdateLinks:=0, _
                                 ReadOnly:=True, AddToMRU:=False)
            End If
    
            For Each ws In wb.Worksheets
            'are we interested in this sheet?
                If Not IsError(Application.Match(ws.Name, arrWs, 0)) Then
                    Set matchedCells = FindAll(ws.UsedRange, BOM) 'get all cells with bom
                    If matchedCells.Count > 0 Then
                        For Each Cell In matchedCells
                            If Cell.EntireRow.Range("H1").Value = "" Then
                                summRow = summRow + 1
                                WsOut.Cells(summRow, 1).Resize(1, 6).Value = _
                                Array(wb.Name, ws.Name, Cell.Address, Cell.Value, _
                                        Cell.EntireRow.Range("F1").Value, Cell.EntireRow.Range("H1").Value)
                
                                numHits = numHits + 1
                            End If
                        Next Cell     'next match
                    End If            'any bom matches
                End If                'matched sheet name
            Next ws
            If Not xBol Then wb.Close False 'need to close this workbook?
        Next f

        With WsOut
            Dim lastrow As Long
            .Columns("A:F").EntireColumn.AutoFit
            lastrow = WsOut.Cells(WsOut.Rows.Count, "E").End(xlUp).Row  'AutoSum all values
            
            .Range("E" & lastrow + 1).Value = WorksheetFunction.Sum(WsOut.Range("E2:E" & lastrow + 1))
        End With
        With ThisWorkbook.Worksheets("Cable Work Order").Range("O1")
            .Font.Color = RGB(240, 240, 240)
            .Value = WsOut.Range("E" & lastrow + 1).Value
        End With

        For i = 2 To Excel.WorksheetFunction.CountA(Range("A:A"))                                        'Autocopy sum value
            If Range("A" & i).Value = BOM Then
               If Range("H" & i).Value = "" Then
                Range("O1").Copy
                With Range("F" & i)
                    .PasteSpecial xlPasteValues
                    .Font.Bold = True
                    .Font.Color = vbBlue
                End With
                End If
            End If
        Next i
'------------------------------------------------------------Case 2----------------------------------------------------------------------------------'
ElseIf iCell.EntireRow.Range("H1").Value = "1126U" Then
        'BOM = InputBox("The current BoM Code is...", "BoM Calculator v1.1", (iCell.Value))
        BOM = iCell.Value
        scrUpdt = Application.ScreenUpdating
        Application.ScreenUpdating = False

        Set WsOut = ThisWorkbook.Worksheets("SUMMARY")
        WsOut.UsedRange.Delete  'Clearing out previous records (very important!!!)

        summRow = 1
        'sheet names to scan
        arrWs = Array("Cable Work Order")
        WsOut.Cells(summRow, 1).Resize(1, 6).Value = Array("Workbook", "Worksheet", _
                        "Cell", "Text in Cell", "Values corresponding", "Uplift Code")
        For Each f In colFiles
            xBol = (f.Path = pathMainWb)  'file already open?
            If xBol Then
                Set wb = wbAct
            Else
                Set wb = Workbooks.Open(FileName:=f.Path, UpdateLinks:=0, _
                                 ReadOnly:=True, AddToMRU:=False)
            End If
    
            For Each ws In wb.Worksheets
            'are we interested in this sheet?
                If Not IsError(Application.Match(ws.Name, arrWs, 0)) Then
                    Set matchedCells = FindAll(ws.UsedRange, BOM) 'get all cells with bom
                    If matchedCells.Count > 0 Then
                        For Each Cell In matchedCells
                            If Cell.EntireRow.Range("H1").Value = "1126U" Then
                                summRow = summRow + 1
                                WsOut.Cells(summRow, 1).Resize(1, 6).Value = _
                                Array(wb.Name, ws.Name, Cell.Address, Cell.Value, _
                                        Cell.EntireRow.Range("F1").Value, Cell.EntireRow.Range("H1").Value)
                
                                numHits = numHits + 1
                            End If
                        Next Cell     'next match
                    End If            'any bom matches
                End If                'matched sheet name
            Next ws
            If Not xBol Then wb.Close False 'need to close this workbook?
        Next f

        With WsOut
            Dim lastrow2 As Long
            .Columns("A:F").EntireColumn.AutoFit
            lastrow2 = WsOut.Cells(WsOut.Rows.Count, "E").End(xlUp).Row  'AutoSum all values
            
            .Range("E" & lastrow2 + 1).Value = WorksheetFunction.Sum(WsOut.Range("E2:E" & lastrow2 + 1))
        End With
        With ThisWorkbook.Worksheets("Cable Work Order").Range("O1")
            .Font.Color = RGB(240, 240, 240)
            .Value = WsOut.Range("E" & lastrow2 + 1).Value
        End With

        For i = 2 To Excel.WorksheetFunction.CountA(Range("A:A"))                                        'Autocopy sum value
            If Range("A" & i).Value = BOM Then
               If Range("H" & i).Value = "1127U" Then
                Range("O1").Copy
                With Range("F" & i)
                    .PasteSpecial xlPasteValues
                    .Font.Bold = True
                    .Font.Color = vbGreen
                End With
                End If
            End If
        Next i
  '------------------------------------------------------------Case 3----------------------------------------------------------------------------------'
ElseIf iCell.EntireRow.Range("H1").Value = "1127U" Then
        'BOM = InputBox("The current BoM Code is...", "BoM Calculator v1.1", (iCell.Value))
        BOM = iCell.Value
        scrUpdt = Application.ScreenUpdating
        Application.ScreenUpdating = False

        Set WsOut = ThisWorkbook.Worksheets("SUMMARY")
        WsOut.UsedRange.Delete  'Clearing out previous records (very important!!!)

        summRow = 1
        'sheet names to scan
        arrWs = Array("Cable Work Order")
        WsOut.Cells(summRow, 1).Resize(1, 6).Value = Array("Workbook", "Worksheet", _
                        "Cell", "Text in Cell", "Values corresponding", "Uplift Code")
        For Each f In colFiles
            xBol = (f.Path = pathMainWb)  'file already open?
            If xBol Then
                Set wb = wbAct
            Else
                Set wb = Workbooks.Open(FileName:=f.Path, UpdateLinks:=0, _
                                 ReadOnly:=True, AddToMRU:=False)
            End If
    
            For Each ws In wb.Worksheets
            'are we interested in this sheet?
                If Not IsError(Application.Match(ws.Name, arrWs, 0)) Then
                    Set matchedCells = FindAll(ws.UsedRange, BOM) 'get all cells with bom
                    If matchedCells.Count > 0 Then
                        For Each Cell In matchedCells
                            If Cell.EntireRow.Range("H1").Value = "1127U" Then
                                summRow = summRow + 1
                                WsOut.Cells(summRow, 1).Resize(1, 6).Value = _
                                Array(wb.Name, ws.Name, Cell.Address, Cell.Value, _
                                        Cell.EntireRow.Range("F1").Value, Cell.EntireRow.Range("H1").Value)
                
                                numHits = numHits + 1
                            End If
                        Next Cell     'next match
                    End If            'any bom matches
                End If                'matched sheet name
            Next ws
            If Not xBol Then wb.Close False 'need to close this workbook?
        Next f

        With WsOut
            Dim lastrow3 As Long
            .Columns("A:F").EntireColumn.AutoFit
            lastrow = WsOut.Cells(WsOut.Rows.Count, "E").End(xlUp).Row  'AutoSum all values
            
            .Range("E" & lastrow3 + 1).Value = WorksheetFunction.Sum(WsOut.Range("E2:E" & lastrow3 + 1))
        End With
        With ThisWorkbook.Worksheets("Cable Work Order").Range("O1")
            .Font.Color = RGB(240, 240, 240)
            .Value = WsOut.Range("E" & lastrow3 + 1).Value
        End With

        For i = 2 To Excel.WorksheetFunction.CountA(Range("A:A"))                                        'Autocopy sum value
            If Range("A" & i).Value = BOM Then
               If Range("H" & i).Value = "1127U" Then
                Range("O1").Copy
                With Range("F" & i)
                    .PasteSpecial xlPasteValues
                    .Font.Bold = True
                    .Font.Color = vbMagenta
                End With
                End If
            End If
        Next i


ElseIf iCell.EntireRow.Range("H1").Value = "1128U" Then  '------------------------------------------------------------Case 4----------------------------------------------------------------------------------'

    'BOM = InputBox("The current Uplift BoM Code is...", "BoM Calculator v1.1", (iCell.Value))
        BOM = iCell.Value
        scrUpdt = Application.ScreenUpdating
        Application.ScreenUpdating = False

        Set WsOut = ThisWorkbook.Worksheets("SUMMARY")
        WsOut.UsedRange.Delete  'Clearing out previous records (very important!!!)

        summRow = 1
        'sheet names to scan
        arrWs = Array("Cable Work Order")
        WsOut.Cells(summRow, 1).Resize(1, 6).Value = Array("Workbook", "Worksheet", _
                        "Cell", "Text in Cell", "Values corresponding", "Uplift Code")
        For Each f In colFiles
            xBol = (f.Path = pathMainWb)  'file already open?
            If xBol Then
                Set wb = wbAct
            Else
                Set wb = Workbooks.Open(FileName:=f.Path, UpdateLinks:=0, _
                                 ReadOnly:=True, AddToMRU:=False)
            End If
    
            For Each ws In wb.Worksheets
            'are we interested in this sheet?
                If Not IsError(Application.Match(ws.Name, arrWs, 0)) Then
                    Set matchedCells = FindAll(ws.UsedRange, BOM) 'get all cells with bom
                    If matchedCells.Count > 0 Then
                        For Each Cell In matchedCells
                            If Cell.EntireRow.Range("H1").Value = "1128U" Then
                                summRow = summRow + 1
                                WsOut.Cells(summRow, 1).Resize(1, 6).Value = _
                                Array(wb.Name, ws.Name, Cell.Address, Cell.Value, _
                                        Cell.EntireRow.Range("F1").Value, Cell.EntireRow.Range("H1").Value)
                
                                numHits = numHits + 1
                            End If
                        Next Cell     'next match
                    End If            'any bom matches
                End If                'matched sheet name
            Next ws
            If Not xBol Then wb.Close False 'need to close this workbook?
        Next f

        With WsOut
            Dim lastrow4 As Long
            .Columns("A:F").EntireColumn.AutoFit
            lastrow2 = WsOut.Cells(WsOut.Rows.Count, "E").End(xlUp).Row  'AutoSum all values
            
            .Range("E" & lastrow4 + 1).Value = WorksheetFunction.Sum(WsOut.Range("E2:E" & lastrow4 + 1))
        End With
        With ThisWorkbook.Worksheets("Cable Work Order").Range("O1")
            .Font.Color = RGB(240, 240, 240)
            .Value = WsOut.Range("E" & lastrow4 + 1).Value
        End With

        For i = 2 To Excel.WorksheetFunction.CountA(Range("A:A"))                                        'Autocopy sum value
            If Range("A" & i).Value = BOM Then
               If Range("H" & i).Value = "1128U" Then
                Range("O1").Copy
                With Range("F" & i)
                    .PasteSpecial xlPasteValues
                    .Font.Bold = True
                    .Font.Color = vbRed
                End With
                End If
            End If
        Next I

  End If
  Next iCell

 MsgBox "Process completed"


 ExitHandler:
 Application.ScreenUpdating = scrUpdt
 Exit Sub

 ErrHandler:
 MsgBox Err.Description, vbExclamation
 Resume ExitHandler



 End Sub

I am getting the wrong values as you can see below:

In the standard case, when considering the existence of value in column H or not, I have two separate records, which is fine. The situation is complicated when the code is expanded. Then I can get the value for a third record, but the second record is still the same whereas the value should be deducted by the value of record 3.

Is there a way of setting the conditions for any value, which varies from each other?

I was thinking about multiple or conditions Compress multiple OR-conditions in VBA code

but they don't work in my case. Will the Case - switch option be better for example? Or Nested if conditions? I need to make sure, that the code treats every single value in the H column differently from each other. So maybe this approach could be helpful: Quicker way to get all unique values of a column in VBA?

Answer 1

I've refactored your code, this does exactly the same as your original code you posted but more concisely. It's in two parts, one triggers the other.

Sub Better_SearchFolders_Cables()

'Variables, by type:
Dim wbAct As Workbook
Dim fldrPath As String, BomCodes As String
Dim scrUpdt As Boolean
Dim colFiles As Collection
Dim Lrow As Long, Row As Long, lastRow As Long
Dim Cell As Range
Dim wsOut As Worksheet

Set wbAct = ActiveWorkbook

On Error GoTo ErrHandler

fldrPath = UserSelectFolder("Select a folder")
If fldrPath = "" Then Exit Sub

'Get all files in the selected folder
Set colFiles = GetFileMatches(fldrPath, "*.xls*", False) 'False = no subfolders
If colFiles.Count = 0 Then
    MsgBox "No Excel files found in selected folder", vbOKOnly + vbExclamation, "Exiting Procedure"
    Exit Sub
End If

scrUpdt = Application.ScreenUpdating
Application.ScreenUpdating = False

'This string contains all the possible bom codes including the blank one, separated by | characters
'so you can check for boms in a single line
BomCodes = "||1126U|1627U|1688U|1887U|1985U|4100U|MDU501U|"

Lrow = Cells(Rows.Count, 1).End(xlUp).Row
Set wsOut = ThisWorkbook.Worksheets("SUMMARY")

For Row = 2 To Lrow
    If BomCodes Like "*|" & Range("H" & Row) & "|*" Then
        With wsOut
            .UsedRange.Delete
            .Range("A1:F1").Value = Array( _
                "Workbook", "Worksheet", "Cell", "Text in Cell", "Values corresponding", "Uplift Code")
        
        Call BomHandler(Row, colFiles, wsOut) 'iCell = Range("A" & row), boms are same but col H
            
            .Columns("A:F").EntireColumn.AutoFit
            lastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
            .Range("E" & lastRow + 1).Value = WorksheetFunction.Sum(.Range("E2:E" & lastRow + 1))
        End With 'wsOut
        With ThisWorkbook.Worksheets("Cable Work Order").Range("O1")
            .Font.Color = RGB(240, 240, 240)
            .Value = wsOut.Range("E" & lastRow + 1).Value
        End With
    End If
Next

ExitHandler:
Application.ScreenUpdating = scrUpdt
Exit Sub

ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler

End Sub

Private Sub BomHandler(Row As Long, colFiles As Collection, wsOut As Worksheet)
Dim strBOM As String
Dim SummRow As Long, NumHits As Long
Dim f As Object, xBol As Boolean
Dim wb As Workbook, ws As Worksheet

strBOM = Range("A" & Row).Value
strInput = Range("H" & Row).Value
SummRow = 1

For Each f In colFiles
    xBol = (f.Path = ActiveWorkbook.FullName)
    If xBol Then
        Set wb = ActiveWorkbook
    Else
        Set wb = Workbooks.Open(filename:=f.Path, UpdateLinks:=0, _
                                 ReadOnly:=True, AddToMRU:=False)
    End If
    
    For Each ws In wb.Worksheets
        If ws.Name Like "Cable Work Order" Then
            Set matchedCells = FindAll(ws.UsedRange, strBOM) 'Get all cells with bom
            If matchedCells.Count > 0 Then
                For Each Cell In matchedCells
                    If ws.Range("H" & Cell.Row) = strInput Then
                        SummRow = SummRow + 1
                        wsOut.Range("A" & SummRow & ":F" & SummRow).Value = Array( _
                            wb.Name, ws.Name, Cell.Address, Cell.Value, ws.Range("F" & Cell.Row).Value, ws.Range("H" & Cell.Row).Value)
                        NumHits = NumHits + 1
                    End If
                Next    'next match
            End If      'any bom matches
        End If          'matched sheet name
    Next                'sheet
    If Not xBol Then wb.Close False
Next f

For I = 2 To Application.WorksheetFunction.CountA(Range("A:A"))                                        'Autocopy sum value
    If Range("A" & I).Value = strBOM Then
       If Range("H" & I).Value = strInput Then
        Range("O1").Copy
        With Range("F" & I)
            .PasteSpecial xlPasteValues
            .Font.Bold = True
            .Font.Color = vbBlue
        End With
        End If
    End If
Next I
End Sub

Answer 2

I sorted it, but the way is quite mundane, therefore the question still remains valid.

I've used the multiple or statement, which looks like this:

 '.................first case the same as above............

ElseIf iCell.EntireRow.Range("H1").Value = "1126U" _
Or iCell.EntireRow.Range("H1").Value = "1672U" _
Or iCell.EntireRow.Range("H1").Value = "1688U" _
Or iCell.EntireRow.Range("H1").Value = "1887U" _
Or iCell.EntireRow.Range("H1").Value = "1985U" _
Or iCell.EntireRow.Range("H1").Value = "4100U" _
Or iCell.EntireRow.Range("H1").Value = "MDU501U" _
Then

   '-------------code as above '-------------------

  If matchedCells.Count > 0 Then
                        For Each Cell In matchedCells
                            If Cell.EntireRow.Range("H1").Value = "1126U" _
                            Or Cell.EntireRow.Range("H1").Value = "1672U" _
                            Or Cell.EntireRow.Range("H1").Value = "1688U" _
                            Or Cell.EntireRow.Range("H1").Value = "1887U" _
                            Or Cell.EntireRow.Range("H1").Value = "1985U" _
                            Or Cell.EntireRow.Range("H1").Value = "4100U" _
                            Or Cell.EntireRow.Range("H1").Value = "MDU501U" _
                            Then

'-------------------------------- another part of the code as above

   For i = 2 To Excel.WorksheetFunction.CountA(Range("A:A"))                                        
  'Autocopy sum value
            If Range("A" & i).Value = BOM Then
               If Range("H" & i).Value = "1126U" _
               Or Range("H" & i).Value = "1672U" _
               Or Range("H" & i).Value = "1688U" _
               Or Range("H" & i).Value = "1887U" _
               Or Range("H" & i).Value = "1985U" _
               Or Range("H" & i).Value = "4100U" _
               Or Range("H" & i).Value = "MDU501U" _
               Then

Answer 3

From what I understand of your code it summates column F for combinations of column A and column H.

Option Explicit

Sub SearchFolders_Cables()

    Dim FOLDER As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select a folder"
        .InitialFileName = ""
        .Show
        .AllowMultiSelect = False
        If .SelectedItems.Count = 0 Then 'If no folder is selected, abort
            MsgBox "You did not select a folder"
            Exit Sub
        End If
        FOLDER = .SelectedItems(1) & "\" 'Assign selected folder to Folder
    End With

    Dim wb As Workbook, ws As Worksheet, lastrow As Long, r As Long
    Dim dict, k, n As Long, t0 As Single: t0 = Timer
    
    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Cable Work Order") ' ActiveSheet
    
    ' build dictionary for totals
    Set dict = CreateObject("Scripting.Dictionary")
    With ws
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For r = 2 To lastrow
            ' key - Uplift Code & BOM
            k = Trim(.Cells(r, "H")) & vbTab & Trim(.Cells(r, "A"))
            If Not dict.exists(k) And Len(k) > 1 Then
                dict.Add k, 0
            End If
        Next
    End With
    'For Each k In dict.keys: Debug.Print k, dict(k): Next
    
    ' search workbooks in folder
    Dim arrWs, wbF As Workbook, wsF As Worksheet
    Dim f As String
   
    arrWs = Array("Cable Work Order")
    
    f = Dir(FOLDER & "*.xls*")
    Application.ScreenUpdating = False
    Do While Len(f) > 0
       n = n + 1
       Set wbF = Workbooks.Open(FOLDER & f, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
       For Each wsF In wbF.Sheets
           If IsError(Application.Match(wsF.Name, arrWs, 0)) Then
                'Debug.Print "Skipped", wbF.Name, wsF.Name
           Else
                ' process sheet
                Call ProcessSheet(wsF, dict)
            End If
        Next
        ' close workbook
        wbF.Close
        f = Dir
    Loop
    
    ' update results
    With ws
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For r = 2 To lastrow
            k = Trim(.Cells(r, "H")) & vbTab & Trim(.Cells(r, "A"))
            If dict.exists(k) Then
                .Cells(r, "F") = dict(k)
            End If
        Next
    End With
    Application.ScreenUpdating = True
    
    MsgBox n & " files scanned in " & FOLDER, vbInformation, Format(Timer - t0, "0.0 secs")
End Sub

Sub ProcessSheet(ws, dict)
    Dim lastrow As Long, r As Long, k As String
    With ws
        lastrow = ws.UsedRange.Row + ws.UsedRange.Rows.Count - 1
        For r = 1 To lastrow
            k = Trim(.Cells(r, "H")) & vbTab & Trim(.Cells(r, "A"))
            ' sum quantity
            If dict.exists(k) Then
                dict(k) = dict(k) + .Cells(r, "F")
            End If
        Next
    End With
End Sub

Start with a new workbook, run Setup and createTestFile, Move test file to its own folder and then run the SearchFolders_Cables.

Sub SetUp()
   With ThisWorkbook.Sheets.Add
      .Name = "Cable Work Order"
      .Range("A2:A4") = 1687
      .Range("H2") = "4102U"
      .Range("H4") = "4100U"
   End With
End Sub

Sub createTestFile()
    Dim wb As Workbook, f, H, i As Long
    Set wb = Workbooks.Add(1)
    f = Array(376, 907, 272, 8737, 34039, 18377, 3836, 168, 2732)
    H = Array("1228U", "1226U", "", "4102U", "", "4100U", "4102U", "4100U", "")
    With wb.Sheets(1)
        .Name = "Cable Work Order"
        .Range("A2:A4") = "1682"
        .Range("A5:A7") = "1687"
        .Range("A8:A10") = "4032"
        For i = 2 To 10
           .Cells(i, "F") = f(i - 2)
           .Cells(i, "H") = H(i - 2)
        Next
    End With
    wb.SaveAs "75757151_Test.xlsx"
    wb.Close False
End Sub

Answer 4

I guess you are writing a condition (ElseIf iCell.EntireRow.Range("H1").Value = "1126U" ) for every Code case. So instead of that, get all the possible cases from the sheet and then compare each case inside a for next. The way to get all the unique values is:

  Dim d As Object, c As Range, kode, tmp As String

    Set d = CreateObject("scripting.dictionary")
    For Each c In  Cell.EntireColumn.Range("H")
        tmp = Trim(c.Value)
        If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
    Next c

    For Each kode In d.keys
     
//your code (one if) will be here replacing the code with the variable kode in every place you need to compare it


IF iCell.EntireRow.Range("H1").Value = kode Then
        'BOM = InputBox("The current BoM Code is...", "BoM Calculator v1.1", (iCell.Value))
        BOM = iCell.Value
        scrUpdt = Application.ScreenUpdating
        Application.ScreenUpdating = False

        Set WsOut = ThisWorkbook.Worksheets("SUMMARY")
        WsOut.UsedRange.Delete  'Clearing out previous records (very important!!!)

        summRow = 1
        'sheet names to scan
        arrWs = Array("Cable Work Order")
        WsOut.Cells(summRow, 1).Resize(1, 6).Value = Array("Workbook", "Worksheet", _
                        "Cell", "Text in Cell", "Values corresponding", "Uplift Code")
        For Each f In colFiles
            xBol = (f.Path = pathMainWb)  'file already open?
            If xBol Then
                Set wb = wbAct
            Else
                Set wb = Workbooks.Open(FileName:=f.Path, UpdateLinks:=0, _
                                 ReadOnly:=True, AddToMRU:=False)
            End If
    
            For Each ws In wb.Worksheets
            'are we interested in this sheet?
                If Not IsError(Application.Match(ws.Name, arrWs, 0)) Then
                    Set matchedCells = FindAll(ws.UsedRange, BOM) 'get all cells with bom
                    If matchedCells.Count > 0 Then
                        For Each Cell In matchedCells
                            If Cell.EntireRow.Range("H1").Value = kode Then
                                summRow = summRow + 1
                                WsOut.Cells(summRow, 1).Resize(1, 6).Value = _
                                Array(wb.Name, ws.Name, Cell.Address, Cell.Value, _
                                        Cell.EntireRow.Range("F1").Value, Cell.EntireRow.Range("H1").Value)
                
                                numHits = numHits + 1
                            End If
                        Next Cell     'next match
                    End If            'any bom matches
                End If                'matched sheet name
            Next ws
            If Not xBol Then wb.Close False 'need to close this workbook?
        Next f

        With WsOut
            Dim lastrow3 As Long
            .Columns("A:F").EntireColumn.AutoFit
            lastrow = WsOut.Cells(WsOut.Rows.Count, "E").End(xlUp).Row  'AutoSum all values
            
            .Range("E" & lastrow3 + 1).Value = WorksheetFunction.Sum(WsOut.Range("E2:E" & lastrow3 + 1))
        End With
        With ThisWorkbook.Worksheets("Cable Work Order").Range("O1")
            .Font.Color = RGB(240, 240, 240)
            .Value = WsOut.Range("E" & lastrow3 + 1).Value
        End With

        For i = 2 To Excel.WorksheetFunction.CountA(Range("A:A"))                                        'Autocopy sum value
            If Range("A" & i).Value = BOM Then
               If Range("H" & i).Value = kode Then
                Range("O1").Copy
                With Range("F" & i)
                    .PasteSpecial xlPasteValues
                    .Font.Bold = True
                    .Font.Color = vbMagenta
                End With
                End If
            End If
        Next i




    Next kode

I guess you may need to do a final If with the empty code case. I cant check if the empty string is an space or nothing.

Answer 5

I want to sum up the values falling under code ie. 1682 and uplift code 1126U from all 45 workbooks I have.

I assumed that what you mean is :

I want to sum up the QTY values in column F sheet "Cable Work Order" falling under code ie. 1682 and uplift code 1126U of all 45 workbooks I have.

Also I assumed that the data structure in sheet "Cable Work Order" of all those 45 workbooks are the same, which looks like your first image ---> consist of 8 header columns starting from column A to column H.

Example case:
a test folder consist 4 excel files, 01.xlsm to 04.xlsm.
in 01.xlsm there is no sheet "Cable Work Order".

Sub test()
Application.ScreenUpdating = False

On Error Resume Next
Sheets("DATA").Activate
If Err.Number > 0 Then
    Sheets.Add.Name = "DATA"
    Range("A1:J1").Value = Array("Code", "colB", "colC", "colD", "colE", "QTY", "colG", "UPLIFT", "WB", "WS")
Else
    Sheets("DATA").Rows("2:60000").Clear
End If
On Error GoTo 0

Dim oFill As Range
Set oFill = Sheets("DATA").Range("A2")

Dim FSO As Object, folder As Object, file As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set folder = FSO.GetFolder("D:\test\")

For Each file In folder.Files
        With Workbooks.Open(file)
            On Error GoTo nxt:
            With .Sheets("Cable Work Order").UsedRange
                .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0).Copy Destination:=oFill
                oFill.Offset(0, 8).Resize(.Rows.Count - 1, 1).Value = ActiveWorkbook.Name
                oFill.Offset(0, 9).Resize(.Rows.Count - 1, 1).Value = "Cable Work Order"
            End With
                Set oFill = oFill.End(xlDown).Offset(1, 0)
nxt:
        .Close SaveChanges:=False
        End With
Next file

'Call SummaryUsingPivotTable

End Sub

The sub above gives a result in sheet DATA something like this :

Basically, the test sub is just copying each table in sheet "Cable Work Order" of each looped workbook into sheet DATA.

When the loop done, sheet DATA has all data which are from sheet "Cable Work Order" (IF ANY) of those 4 workbooks in test folder.

The second sub is to summarize the data using pivot table :

Sub SummaryUsingPivotTable()

On Error Resume Next
Sheets("SUMMARY").Activate
If Err.Number > 0 Then
Sheets.Add.Name = "SUMMARY"
Else
Sheets("SUMMARY").Cells.Clear
End If
On Error GoTo 0

With ActiveWorkbook
.Names.Add Name:="data", RefersTo:=Sheets("DATA").UsedRange
.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "data", Version:=xlPivotTableVersion14).CreatePivotTable TableDestination:= _
        "SUMMARY!R1C1", TableName:="PivotTable1", DefaultVersion:= _
        xlPivotTableVersion14
End With

    With Sheets("SUMMARY").PivotTables(1)
        With .PivotFields("CODE")
        .Orientation = xlRowField
        .Position = 1
        End With
        With .PivotFields("UPLIFT")
        .Orientation = xlRowField
        .Position = 2
        End With
        .AddDataField ActiveSheet.PivotTables(1).PivotFields("QTY"), "Sum of QTY", xlSum
        .RowAxisLayout xlTabularRow
    End With

End Sub

Pivot table result in sheet SUMMARY:

Pivot table result in sheet SUMMARY with the workbook name: