VBA Excel - autosum values from all workbooks in the directory

Question

I have the code such as this for opposite conditions.

For Each iCell In Range("A2:A6").Cells
    If iCell.EntireRow.Range("H1").Value = "" Then
        BOM = InputBox("The current BoM Code is...", "BoM Calculator v1.1", (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("Civils Work Order", "Cable Work Order", "BoM")
        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:E").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


        MsgBox numHits & " cells have been found", , "BoM Calculator for VM Greenfield"

  Else  '----------------OPPOSITE CONDITIONS---------------------'

    BOM = InputBox("The current Uplift BoM Code is...", "BoM Calculator v1.1", (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("Civils Work Order", "Cable Work Order", "BoM")
        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 lastrow2 As Long
            .Columns("A:E").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" & lastrow + 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 <> "" Then
                Range("O1").Copy
                With Range("F" & i)
                    .PasteSpecial xlPasteValues
                    .Font.Bold = True
                    .Font.Color = vbRed
                End With
                End If
            End If
        Next i

'ThisWorkbook.Worksheets("Civils Work Order").Columns("O").Font.Color = RGB(10, 10, 10)

        MsgBox numHits & " cells have been found", , "BoM Calculator for VM Greenfield"
        'Const Timeout = 2

   End If
  Next iCell

Is it a chance for some compression?

Answer 1

The first optimization would be to combine those two identical paths into one with boolean logic.

I did this by loading each half of the top level If statement in a side by side comparison. Then I used logic to account for the differences in each path, of which there are only a few. rowIsBlank hold the answer to that initial top level If you are concerned with. It's then used to account for the differences.

    For Each iCell In Range("A2:A6").Cells
        Dim rowIsBlank As Boolean
        rowIsBlank = iCell.EntireRow.Range("H1").Value = ""
        Dim inputMessage As String
        inputMessage = "The current"
        If rowIsBlank Then inputMessage = inputMessage & " Uplift"
        inputMessage = inputMessage & " BoM Code is..."
        BOM = InputBox(inputMessage, "BoM Calculator v1.1", (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("Civils Work Order", "Cable Work Order", "BoM")
        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 rowIsBlank = (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:E").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 rowIsBlank = (Range("H" & i).Value = "") Then
                    Range("O1").Copy
                    With Range("F" & i)
                        .PasteSpecial xlPasteValues
                        .Font.Bold = True
                        .Font.Color = IIf(rowIsBlank, vbBlue, vbRed)
                    End With
                End If
            End If
        Next i

        MsgBox numHits & " cells have been found", , "BoM Calculator for VM Greenfield"
    Next iCell