Macro to subtract multiple cells and output the results

Question

I found a macro that subtracts the values in one cell in a workbook from another cell in a workbook to output the result in a final third workbook. It exists as such

Sub Sample()
    Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook
    Dim lngDiff As Long

    On Error GoTo Err

    Application.ScreenUpdating = False

    Set wb1 = ActiveWorkbook

    Set wb2 = Workbooks.Open("C:\FirstDataFile.xlsx")
    Set wb3 = Workbooks.Open("C:\SecondDataFile.xlsx")

    lngDiff = wb2.Sheets("Sheet1").Range("A1").Value - _
              wb3.Sheets("Sheet1").Range("A1").Value

    wb1.Sheets("Sheet1").Range("A1").Value = lngDiff

    wb3.Close savechanges:=False
    wb2.Close savechanges:=False

    Application.ScreenUpdating = True
    Exit Sub
Err:
    MsgBox Err.Description
End Sub

Is there anyway to modify this code that it can do this for multiple lines at once.

For example. get it to subtract wb2.Sheets("Sheet1").Range("A1").Value - _ wb3.Sheets("Sheet1").Range("A1").Value and output that result into wb1.Sheets("Sheet1").Range("A1").Value and then do the same for A2, A3 and so on so forth until about A:120000? I would also like to be able to get this done on multiples sheets on the two books that I am drawing info from. How would this be done?

Thanks!

Pᴇʜ Pᴇʜ · Accepted Answer · 2020-01-10T14:18:03

I suggest to use a loop through a list of worksheet names, and outsource the subtraction to subroutine InAllValuesOfColumnA that loops through all rows of each sheet as shown below. I further recommend to use meaningful variable names instead of numbered variables (which is a bad practice and easily gets mixed up).

Option Explicit

Public Sub ExampleSample()
    Dim wbResult As Workbook, wbData As Workbook, wbSubtract As Workbook
    Dim lngDiff As Long

    On Error GoTo Err

    Application.ScreenUpdating = False

    Set wbResult = ActiveWorkbook
    Set wbData = Workbooks.Open("C:\FirstDataFile.xlsx")
    Set wbSubtract = Workbooks.Open("C:\SecondDataFile.xlsx")

    Dim WorksheetList() As Variant
    WorksheetList = Array("Sheet1", "Sheet2") 'add the worksheet names here

    Dim WsName As Variant
    For Each WsName In WorksheetList
        InAllValuesOfColumnA OfWorksheet:=wbData.Worksheets(WsName), SubtractWorksheet:=wbSubtract.Worksheets(WsName), WriteToWorksheet:=wbResult.Worksheets(WsName)
    Next WsName

    wbData.Close SaveChanges:=False
    wbSubtract.Close SaveChanges:=False

    Application.ScreenUpdating = True
    Exit Sub
Err:
    MsgBox Err.Description
End Sub


Private Sub InAllValuesOfColumnA(ByVal OfWorksheet As Worksheet, ByVal SubtractWorksheet As Worksheet, ByVal WriteToWorksheet As Worksheet)
    Dim LastRow As Long
    LastRow = OfWorksheet.Cells(OfWorksheet.Rows.Count, "A").End(xlUp).Row

    Dim iRow As Long
    For iRow = 1 To LastRow 'run from first to last row and subtract
        WriteToWorksheet.Cells(iRow, "A").Value = CLng(OfWorksheet.Cells(iRow, "A").Value - SubtractWorksheet.Cells(iRow, "A").Value)
    Next iRow
End Sub

An even faster way would be to read/write the data into arrays before/after calculation:

Private Sub InAllValuesOfColumnA(ByVal OfWorksheet As Worksheet, ByVal SubtractWorksheet As Worksheet, ByVal WriteToWorksheet As Worksheet)
    Dim LastRow As Long
    LastRow = OfWorksheet.Cells(OfWorksheet.Rows.Count, "A").End(xlUp).Row

    'read all into array
    Dim DataColumn() As Variant
    DataColumn = OfWorksheet.Range("A1:A" & LastRow).Value

    Dim SubtractColumn() As Variant
    SubtractColumn = SubtractWorksheet.Range("A1:A" & LastRow).Value

    Dim ResultColumn() As Variant
    ResultColumn = WriteToWorksheet.Range("A1:A" & LastRow).Value


    Dim iRow As Long
    For iRow = LBound(ResultColumn) To UBound(ResultColumn) 'run from first to last row and subtract
        ResultColumn(iRow) = CLng(DataColumn(iRow) - SubtractColumn(iRow))
    Next iRow

    WriteToWorksheet.Range("A1:A" & LastRow).Value = ResultColumn
End Sub

Macro to subtract multiple cells and output the results

1 Answers