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