Как сложить и вычесть среди нескольких листов в тех же столбцах?

Question

Мне нужна помощь! У меня 6 листов. Все они начинаются с A2: D. Каждый содержит:

• a = треска
• b = марка
• c = тип
• d = количество

Я хочу, чтобы результат показа на Листе 6 был копией данных от А до C. И D должен следовать этой формуле: D= Sheet1 + Sheet2 - Sheet3 - Sheet4 + Sheet5

Я ищу по inte rnet, и я нашел этот код. Но я не могу настроить это, чтобы делать то, что я хочу.

Кто-нибудь может помочь?

Sub Get_Data()
    Dim My_array(1 To 5)
    Dim i As Byte, m%
    m = Sheets("sheet6").Cells(Rows.Count, 1).End(3).Row + 1
    Dim lr%, MY_sh As Worksheet
    Dim RG_to_copy As Range
    My_array(1) = "sheet1": My_array(2) = "sheet2"
    My_array(3) = "sheet3": My_array(4) = "sheet4"
    My_array(5) = "sheet5"

    For i = 1 To 5
        Set MY_sh = Sheets(My_array(i))
        lr = MY_sh.Cells(Rows.Count, 1).End(3).Row
        Set RG_to_copy = MY_sh.Range("A2:D" & lr)
        RG_to_copy.Copy Sheets("sheet6").Cells(m, 1)
        m = lr + 1
    Next
End Sub

Требуемый результат показан на последнем изображении.

Он копирует данные, начиная с shee1, на лист5 из диапазона A2: D. Но столбец D содержит математическую сумму и вычитание между пятью листами.

Answer 1

Попробуйте этот код (не проверено):

Sub Get_Data()
    Dim My_array(1 To 5, 1 To 2), RSh As Worksheet

    On Error Resume Next

    'Change the sheets names if they are different,and signs
    My_array(1, 1) = "sheet1": My_array(1, 2) = "1"
    My_array(2, 1) = "sheet2": My_array(2, 2) = "1"
    My_array(3, 1) = "sheet3": My_array(3, 2) = "-1"
    My_array(4, 1) = "sheet4": My_array(4, 2) = "-1"
    My_array(5, 1) = "sheet5": My_array(5, 2) = "1"
    Set RSh = Sheets("sheet6")

    Dim r As Long, rMax As Long, i As Long, Fnd As Range, m As Long
    m = RSh.Cells(Rows.Count, 1).End(xlUp).Row + 1
    RSh.Range(RSh.Cells(2, 1), RSh.Cells(m, 6)).ClearContents
    m = 2
    For i = LBound(My_array, 1) To UBound(My_array, 1)
        With Sheets(My_array(i, 1))
            rMax = .Cells(.Rows.Count, 1).End(xlUp).Row
            For r = 2 To rMax
                Set Fnd = RSh.Columns(1).Find(.Cells(r, 1).Value, LookAt:=xlWhole)
                If Fnd Is Nothing Then
                    RSh.Range(RSh.Cells(m, 1), RSh.Cells(m, 3)).Value = .Range(.Cells(r, 1), .Cells(r, 3)).Value
                    RSh.Cells(m, 4).Value = .Cells(r, 4).Value * My_array(i, 2)
                    m = m + 1
                Else
                    RSh.Cells(Fnd.Row, 4).Value = RSh.Cells(Fnd.Row, 4).Value + (.Cells(r, 4).Value * My_array(i, 2))
                End If
            Next r
        End With
    Next i
End Sub