Sum up the amount for unique records from multiple tabs

[Beatrix]

Hi All

I am working on a spreadsheet with multiple tabs. There are 12 individual worksheets which displays data for the period from April 16 to March 17. Each worksheet has the same structure but different number of columns. The column numbers I need to use is from Column number 3 to Column 11. I need to sum up the amounts of unique records based on 3 unique ID in column 3, column 6 and column 9 in each worksheet and at the end need to create a master tab which lists the total amount for each unique record details.

I attached a test sample file which displays 12 months data and the end result Master tab.

I was wondering if anyone could help me with this please?

Cheers
B.

[SamT]

I don't know if this fits your situation, but a while back I worked on a project with many identical categories spread over many sheets (CostSheets array.) This allowed me to use formulas in the Categories summary sheet

Dim CostSheets As Variant

Private Sub Initialize_CostSheets()
CostSheets = Array("Common_Area", "Parking", "Direct Building", "Sitework", _
                   "Rec-Leasing", "Retail", "General Conditions")

End Sub

Public Function SumIfAllSheets(MatchRange As String, _
                               Criteria As Range, _
                               SumRange As String) _
                               As Double
                               
 Dim i As Long
 Dim Temp As Double
 Dim WSF As Object
 
 Temp = 0
 
  On Error Resume Next
  If CostSheets(0) = "" Then
    Initialize_CostSheets
  End If
  On Error GoTo 0
 
 Set WSF = Application.WorksheetFunction
 
  For i = LBound(CostSheets) To UBound(CostSheets)
   With Sheets(CostSheets(i))
    Temp = Temp + WSF.SumIf(.Range(MatchRange), Criteria, Range(SumRange))
   End With
  Next i

  SumIfAllSheets = Temp

End Function

[mdmackillop]

Are the values in columns 4,5,7,8,10 the same for each combination? If not, what goes into the Master?

[mdmackillop]

Option Explicit


Sub test()
Dim sh As Worksheet
Dim Dic
Dim i
Dim x As String, y As Single
Dim k


Set Dic = CreateObject("Scripting.Dictionary")
For Each sh In Worksheets
With sh
If .Name <> "Master" Then
For i = 2 To LR(sh, 1)
x = .Cells(i, 3) & "-" & .Cells(i, 6) & "-" & .Cells(i, 9)
y = .Cells(i, 11)
If Dic.exists(x) Then
    Dic(x) = CStr(Dic(x) + y)
Else
   Dic.Add x, CStr(y)
End If
Next i
End If
End With
Next sh
Set sh = Sheets("Master")
i = 1
For Each k In Dic.Keys
    i = i + 1
    Cells(i, 1) = Split(k, "-")(0)
    Cells(i, 4) = Split(k, "-")(1)
    Cells(i, 7) = Split(k, "-")(2)
    Cells(i, 9) = Dic(k)
Next
Range("A2:G" & i).NumberFormat = "0000"
End Sub




Function LR(sh, col) As Long
LR = sh.Cells(Rows.Count, col).End(xlUp).Row
End Function

[Beatrix]

Hi mdmackillop

That's working great!! Thanks very much for your time and help. I'll practice on this script to be able to do next similar task. I understand your script but I still can't put things together by myself. Thank you so much!! Much much appreciated.

Cheers
B.

[Beatrix]

Hi SamT

Thank you so much for your script, I am not there yet regarding my VBA skills, I will break it down line by line and will do practice after I understand how it works. Many thanks tho. I am learning a lot from VBA express with VBA GURUs' support

Cheers
B.

[Beatrix]

Hi mdmackillop

I am having a run time error "13" Type mismatch when I adjust the script based on the original file. When I debug it highlights

y = .Cells(i, 11)

I am sure the data format is exactly the same with the sample test file. I really don't know what's causing to this problem

Sub test()
    Dim sh As Worksheet
    Dim Dic
    Dim i
    Dim x As String, y As Single
    Dim k
     
     
    Set Dic = CreateObject("Scripting.Dictionary")
    For Each sh In Worksheets
        With sh
            If .Name <> "Master" Then
                For i = 2 To LR(sh, 1)
                    x = .Cells(i, 3) & "-" & .Cells(i, 4) & "-" & .Cells(i, 5) & "-" & .Cells(i, 6) & "-" & .Cells(i, 7) & "-" & .Cells(i, 8) & "-" & .Cells(i, 9) & "-" & .Cells(i, 10)
                    y = .Cells(i, 11)
                    If Dic.exists(x) Then
                        Dic(x) = CStr(Dic(x) + y)
                    Else
                        Dic.Add x, CStr(y)
                    End If
                Next i
            End If
        End With
    Next sh
    Set sh = Sheets("Master")
    i = 1
    For Each k In Dic.Keys
        i = i + 1
        Cells(i, 1) = Split(k, "-")(0)
        Cells(i, 2) = Split(k, "-")(1)
        Cells(i, 3) = Split(k, "-")(2)
        Cells(i, 4) = Split(k, "-")(3)
        Cells(i, 5) = Split(k, "-")(4)
        Cells(i, 6) = Split(k, "-")(5)
        Cells(i, 7) = Split(k, "-")(6)
        Cells(i, 8) = Split(k, "-")(7)
        Cells(i, 9) = Dic(k)
    Next
     Range("A2:G" & i).NumberFormat = "0000"
   
End Sub
 
 
 
 
Function LR(sh, col) As Long
    LR = sh.Cells(Rows.Count, col).End(xlUp).Row
End Function

[mdmackillop]

The final lines should be changed as follows to ensure that results are written to Master.

Set sh = Sheets("Master")
    With sh
    i = 1
    For Each k In Dic.Keys
        i = i + 1
        .Cells(i, 1) = Split(k, "-")(0)
        .Cells(i, 2) = Split(k, "-")(1)
        .Cells(i, 3) = Split(k, "-")(2)
        .Cells(i, 4) = Split(k, "-")(3)
        .Cells(i, 5) = Split(k, "-")(4)
        .Cells(i, 6) = Split(k, "-")(5)
        .Cells(i, 7) = Split(k, "-")(6)
        .Cells(i, 8) = Split(k, "-")(7)
        .Cells(i, 9) = Dic(k)
    Next
    .Range("A2:G" & i).NumberFormat = "0000"
    End With

If you still have the error, check the sheet relevant to that line when the code fails.

[Beatrix]

Many thanks for your response mdmackillop

I tested each worksheet to find the problem and the problem was blank cells in Amount column. I've learned my lesson, next time I'll check the blank cells first in any data sets.

Cheers
B.

[mdmackillop]

If blanks are a possibility then the code can be amended to cope. If your require assistance please post a "problem" workbook.

[snb]

Sub M_snb()
  With CreateObject("Scripting.Dictionary")
    For Each sh In Worksheets
      If sh.Name <> "Master" Then
        sn = sh.Cells(1).CurrentRegion
                
        For j = 2 To UBound(sn)
          .Item(sn(j, 3) & "_" & sn(j, 6) & "_" & sn(j, 9)) = .Item(sn(j, 3) & "_" & sn(j, 6) & "_" & sn(j, 9)) + sn(j, 11)
        Next
      End If
    Next
    y = .Count
    Application.DisplayAlerts = False
    Sheets("Master").Cells(2, 14).Resize(.Count, 4) = Application.Transpose(Array(.keys, .keys, .keys, .items))
  End With
        
  With Sheets("Master")
    .Cells(2, 14).Resize(y).TextToColumns , , , , 0, 0, 0, 0, -1, "_"
    .Cells(2, 1).Resize(y) = .Cells(2, 14).Resize(y).Value
    .Cells(2, 4).Resize(y) = .Cells(2, 15).Resize(y).Value
    .Cells(2, 7).Resize(y) = .Cells(2, 16).Resize(y).Value
    .Cells(2, 9).Resize(y) = .Cells(2, 17).Resize(y).Value
  End With
End Sub