Макрос для вычитания нескольких ячеек и вывода результатов

Question

Я нашел макрос, который вычитает значения в одной ячейке рабочей книги из другой ячейки рабочей книги, чтобы вывести результат в окончательную третью рабочую книгу. Он существует как таковой

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

Есть ли способ изменить этот код, чтобы он мог делать это для нескольких строк одновременно.

Например. заставить его вычесть wb2.Sheets ("Sheet1"). Range ("A1"). Value - _ wb3.Sheets ("Sheet1"). Range ("A1"). Значение и вывод, которые приводят к wb1.Sheets (" Sheet1 "). Range (" A1 "). Значение, а затем сделать то же самое для A2, A3 и т. Д. До примерно A: 120000? Я также хотел бы быть в состоянии сделать это на нескольких листах на двух книгах, из которых я получаю информацию. Как это будет сделано?

Спасибо!

Answer 1

Я предлагаю использовать al oop в списке имен листов и передать вычитание подпрограмме InAllValuesOfColumnA, которая проходит по всем строкам каждого листа, как показано ниже. Кроме того, я рекомендую использовать значимые имена переменных вместо пронумерованных переменных (что является плохой практикой и легко запутывается).

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

---

Еще более быстрый способ - читать / записывать данные в массивы до / после расчета:

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

Answer 2

Не уверен. Пожалуйста, проверьте это. Убедитесь, что относительные ссылки (без $ в формуле)

    Set wb1 = ActiveWorkbook

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

    wb1.Sheets("Sheet1").Range("A1:A120000").formula = wb2.Sheets("Sheet1").Range("A1").Value -
    wb3.Sheets("Sheet1").Range("A1").Value

with wb1.Sheets("Sheet1").Range("A1:A120000")
.value = .value
end with

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