VBA Code to move Amount Due from individual sheets to a master sheet, and then copy information from the master sheet back to the individual sheets?

[Coyotex3]

Hello, wondering if somebody could help me figure this out, or improve on an existing code?

Please note in this sample I'm using sheets but at work I actually have one master workbook and some individual workbooks where I'm pulling the data from. I can't download the plugin at work, therefore doing my best to recall everything. In truth she sheets contain a lot more columns. But here are the essential details.

I essentially have this master sheet:

Book3
	A	B	C	D	E	F	G	H	I	J
1	A Suite	Jun-24
2	Name	Country	City	Type	Minerals	Games	TV	Toys	Shoes	Total
3	Allucar	USA	NYC	Return						0
4	Diane	JP	Tokyo	New						0
5	Helen	CAN	Vancouver	New						0
6	Radahn	GER	Hamburg	New						0
7	Rennah	USA	Seattle	Return						0
8	Alexander	USA	Fairfax	New						0
9	Ty	USA	NYC	New						0
10	Bayle	JP	Tokyo	Return						0
Sheet1 (2)

Cell Formulas
Range	Formula
J3:J10	J3	=SUM(E3:I3)

And these five individual sheets:

Book3
	A	B	C	D	E	F	G
1	A Suite	Jun-24
2	Name	Country	City	Type	Item A	Amount Due	Credit
3	Emily	USA	NYC	Return	Cars	11963	0
4	Jane	JP	Tokyo	New	Clothing	12017	0
5	Helen	CAN	Vancouver	New	Minerals	11151	0
6	Diane	GER	Hamburg	New	Games	10516	0
7	Jess	USA	Seattle	Return	Games	12688	0
Sheet2

Book3
	A	B	C	D	E	F	G
1	A Suite	Jun-24
2	Name	Country	City	Type	Item A	Amount Due	Credit
3	Ranni	USA	NYC	Return	Cars	10000	0
4	Radahn	JP	Tokyo	New	Clothing	10000	0
5	Rennah	CAN	Vancouver	New	Minerals	10000	0
6	Fia	GER	Hamburg	New	Games	10000	0
Sheet3

Book3
	A	B	C	D	E
1	A Suite	Jun-24	Toys
2	Name	Country	City	Type	Amount Due
3	Blake	USA	NYC	Return	500
4	Clay	JP	Tokyo	New	300
5	Ty	CAN	Vancouver	New	400
6	John	GER	Hamburg	New	200
Sheet5

Book3
	A	B	C	D	E
1	A Suite	Jun-24	Toys
2	Name	Country	City	Type	Amount Due
3	Blake	USA	NYC	Return	500
4	Clay	JP	Tokyo	New	300
5	Ty	CAN	Vancouver	New	400
6	John	GER	Hamburg	New	200
Sheet5

Book3
	A	B	C	D	E
1	A Suite	Jun-24	Shoes
2	Name	Country	City	Type	Amount Due
3	Blaine	USA	NYC	Return	100
4	Allucar	JP	Tokyo	New	500
5	Bayle	CAN	Vancouver	New	350
6	Diane	CAN	Vancouver	New	200
7	Helen	CAN	Vancouver	New	200
Sheet6

And I'd like to get to this:

Book3
	A	B	C	D	E	F	G	H	I	J
1	A Suite	Jun-24
2	Name	Country	City	Type	Minerals	Games	TV	Toys	Shoes	Total
3	Allucar	USA	NYC	Return	0	0	500	0	0	500
4	Diane	JP	Tokyo	New	10516	0	0	0	200	10716
5	Helen	CAN	Vancouver	New	12151	0	0	0	200	12351
6	Radahn	GER	Hamburg	New	0	10000	0	0	0	10000
7	Rennah	USA	Seattle	Return	0	10000	0	0	0	10000
8	Alexander	USA	Fairfax	New	0	0	0	200	0	200
9	Ty	USA	NYC	New	0	0	0	0	0	0
10	Bayle	JP	Tokyo	Return	0	0	0	0	350	350
She1

Cell Formulas
Range	Formula
J3:J10	J3	=SUM(E3:I3)

Sorry if the example is not exactly perfect. I was trying to recreate this sample from memory.

1st I need to pull the total from each "Amount Due" Column in each workbook if the name on sheet(she1) is found on the respective individual billing individual sheet.

Once That is done I want to paste the total from column J back into column G sheets2 and Sheet3 as these sheets contain a column "credit column"


P.S I have this code that helps me get what I need with the real data at work, which uses sumifs to retrieve the data but it feels like this can be improved on for efficiency or for readability. Sorry I could not provide an example of the real data. Still Wondering if you guys had any tips.

Sub Dictionary_Variables()o
Dim dict As Scripting.Dictionary
Dim key As Variant
Dim svc As String, shtName As String
Dim Starttime As Single

 Starttime = timer
Set dict = New Dictionary
With dict
    .Add "xxxx.xlsx", "Sales"
    .Add "xxxx.xlsx", "Sales"
    .Add "xxxx.xlsx", "TV"
    .Add "xxxx", "TOYS"
    .Add "xxxx.xlsx", "Shoes"
End With

  Dim sh1 As Worksheet, sht As Worksheet
  Dim a As Variant, b As Variant, c As Variant, d As Variant, e As Variant
  Dim i As Long, j As Long, LR As Long, LR2 As Long, LR3 As Long, SearchColumn As Long, ResultColumn As Long, OColumn As Long
  Dim LookUp As Range, cName As Range
  Dim PM_COL As Variant, PM_Col2 As Variant
  Dim She1 As Workbook
  Set She1 = Workbooks("yyyy.xlsx"): Set sh1 = She1.Sheets("Sheet1")
  
  shtName = sh1.Range("B1").Value
  
 Application.ScreenUpdating = False
For Each key In dict
    svc = dict(key)
    Set PMSheet = Workbooks(key): Set sht = PMSheet.Sheets(shtName): LR3 = sht.Range("A" & Rows.Count).End(xlUp).Row: LR = sh1.Range("A" & Rows.Count).End(xlUp).Row - 1
    Set LookUp = sht.Rows(2)
    ResultColumn = LookUp.Find("Amount Due", lookat:=xlWhole).Column
    PM_COL = Array("Cars", "Clothing")
    
    If svc = "Sales" Then
        For i = 3 To LR
         If WorksheetFunction.Sum(Range("E" & i & ":H" & i)) = 0 Then
              For Each c In PM_COL
              SearchColumn = sh1.Rows(2).Find(c, lookat:=xlWhole).Column
              e = Mid(Cells(1, SearchColumn).Address(False, False), 1, 1)
                  sh1.Range(e & i).Value = WorksheetFunction.SumIfs(sht.Range(sht.Cells(3, ResultColumn), sht.Cells(LR3, ResultColumn)), sht.Range("A3:A" & LR3), sh1.Range("A" & i), sht.Range("E3:E" & LR3), sh1.Range(e & 2) & "*")
              Next
         End If
        Next
    Else
         SearchColumn = sh1.Rows(2).Find(svc, lookat:=xlWhole).Column
              e = Mid(Cells(1, SearchColumn).Address(False, False), 1, 1)
        For i = 3 To LR
              sh1.Range(e & i).Value = WorksheetFunction.SumIfs(sht.Range(sht.Cells(3, ResultColumn), sht.Cells(LR3, ResultColumn)), sht.Range("A3:A" & LR3), sh1.Range("A" & i))
        Next
   End If
Next key

For Each key In dict
    svc = dict(key)
    Set PMSheet = Workbooks(key): Set sht = PMSheet.Sheets(shtName): LR3 = sht.Range("A" & Rows.Count).End(xlUp).Row: LR = sh1.Range("A" & Rows.Count).End(xlUp).Row - 1
    Set LookUp = sht.Rows(2)
    
    If svc = "Sales" Then
    
    OColumn = LookUp.Find("Credit", lookat:=xlWhole).Column
    d = Mid(Cells(1, OColumn).Address(False, False), 1, 2)
        For i = 3 To LR3
         sht.Range(d & i).Value = sht.Range(d & i).Value
        Next
    Else
        OColumn = LookUp.Find("Sales Pays", lookat:=xlWhole).Column
        d = Mid(Cells(1, OColumn).Address(False, False), 1, 1) ' This might change
        For i = 3 To LR3
         sht.Range(d & i).Value = sht.Range(d & i).Value
        Next
   End If
Next key
Application.ScreenUpdating = True
Debug.Print "Total Time to Run = " & timer - Starttime & " Seconds."
End Sub

.

 

[Coyotex3]

Retrying again as the data I posted last night was riddled with errors. This data should be accurate.

Here is the master workbook:

Test Sample.xlsx
	A	B	C	D	E	F	G	H	I	J	K
1	Master Sheet	June 2024			Service
2	Name	Country	ID#	Sheet	Minerals	Games	TV	Toys	Shoes	Total	Credit Due
3	Allucar	USA	1	xxxx						-	-
4	Diane	JP	2	xxxx						-	-
5	Helen	CAN	3	xxxx						-	-
6	Fia	GER	4	yyyy						-	-
7	Rennah	USA	5	yyyy						-	-
8	Alexander	USA	6	yyyy						-	-
9	Ty	USA	7	yyyy						-	-
10	Bayle	JP	8	xxxx						-	-
11	Totals				-	-	-	-	-	-	-
1

Cell Formulas
Range	Formula
J3:J10	J3	=SUM(E3:I3)
K3:K10	K3	=SUM(E3:F3*0.2)
E11	E11	=SUBTOTAL(109,$E$3:$E$10)
F11	F11	=SUBTOTAL(109,$F$3:$F$10)
G11	G11	=SUBTOTAL(109,$G$3:$G$10)
H11	H11	=SUBTOTAL(109,$H$3:$H$10)
I11	I11	=SUBTOTAL(109,$I$3:$I$10)
J11	J11	=SUBTOTAL(109,$J$3:$J$10)
K11	K11	=SUBTOTAL(109,$K$3:$K$10)

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
I3:K10	Expression	=IF(AND(COUNTIF($A$3:$A3,$A3)>1),OR($D3="[yyyy.xlsx]",$D3="[xxxx.xlsx]"))	text	NO
A10,A3:A6,A8	Cell Value	duplicates	text	NO

Here are the workbooks I'm pulling data from

Test Sample.xlsx
	A	B	C	D	E	F	G
1	Team A	June 2024
2	Name	Country	City	ID	Items	Amount Due	Credit
3	Emily	USA	NYC	10	Cars	11963	0
4	Jane	JP	Tokyo	11	Clothing	12017	0
5	Helen	CAN	Vancouver	12	Minerals	11151	0
6	Diane	GER	Hamburg	13	Games	10516	0
7	Jess	USA	Seattle	14	Games	12688	0
8	Totals					58,335.00	-
2

Cell Formulas
Range	Formula
F8:G8	F8	=SUM(F3:F7)

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
A3:A7	Expression	=AND(ISNUMBER(#REF!),#REF!<1)	text	NO

Test Sample.xlsx
	A	B	C	D	E	F	G
1	Team B	June 2024
2	Name	Country	City	ID	Items	Amount Due	Credit
3	Ranni	USA	NYC	14	Cars	10000	0
4	Radahn	JP	Tokyo	15	Clothing	10000	0
5	Rennah	CAN	Vancouver	16	Minerals	10000	0
6	Rennah	CAN	Vancouver	17	Games	10000	0
7	Fia	GER	Hamburg	17	Games	10000	0
8	Totals					50,000.00	-
3

Cell Formulas
Range	Formula
F8:G8	F8	=SUM(F3:F7)

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
A3:A7	Expression	=AND(ISNUMBER(#REF!),#REF!<1)	text	NO

Test Sample.xlsx
	A	B	C	D	E
1	Team C	June 2024	Shoes
2	Name	Country	City	ID	Amount Due
3	Blaine	USA	NYC	17	100
4	Allucar	JP	Tokyo	18	500
5	Bayle	CAN	Vancouver	19	350
6	Diane	CAN	Vancouver	20	200
7	Helen	CAN	Vancouver	21	200
8	Total				1350
4

Cell Formulas
Range	Formula
E8	E8	=SUM(E3:E7)

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
A3:A6,A8	Expression	=AND(ISNUMBER(#REF!),#REF!<1)	text	NO

Test Sample.xlsx
	A	B	C	D	E
1	Team D	June 2024	Toys
2	Name	Country	City	ID	Amount Due
3	Blake	USA	NYC	22	500
4	Clay	JP	Tokyo	23	300
5	Ty	CAN	Vancouver	24	400
6	John	GER	Hamburg	25	200
7	Alexander	JP	Osaka	26	200
8	Total				1600
5

Cell Formulas
Range	Formula
E8	E8	=SUM(E3:E7)

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
A3:A6,A8	Expression	=AND(ISNUMBER(#REF!),#REF!<1)	text	NO

Test Sample.xlsx
	A	B	C	D	E
1	Team E	June 2024	TV
2	Name	Country	City	ID	Amount Due
3	Fia	USA	NYC	22	500
4	Total				500
6

Cell Formulas
Range	Formula
E4	E4	=SUM(E3:E3)

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
A3:A4	Expression	=AND(ISNUMBER(#REF!),#REF!<1)	text	NO

And here is the expected result:

Test Sample.xlsx
	A	B	C	D	E	F	G	H	I	J	K
1	Master Sheet	June 2024			Service
2	Name	Country	ID#	Sheet	Minerals	Games	TV	Toys	Shoes	Total	Credit Due
3	Allucar	USA	1	xxxx					500.00	500.00	-
4	Diane	JP	2	xxxx		10,516.00			200.00	10,716.00	2,103.20
5	Helen	CAN	3	xxxx	11,151.00				200.00	11,351.00	2,230.20
6	Fia	GER	4	yyyy		10,000.00	500.00			10,500.00	2,000.00
7	Rennah	USA	5	yyyy	10,000.00	10,000.00				20,000.00	4,000.00
8	Alexander	USA	6	yyyy				200.00		200.00	-
9	Ty	USA	7	yyyy				400.00		400.00	-
10	Bayle	JP	8	xxxx					350.00	350.00	-
11	Totals				21,151.00	30,516.00	500.00	600.00	1,250.00	54,017.00	10,333.40
7

Cell Formulas
Range	Formula
J3:J10	J3	=SUM(E3:I3)
K3:K10	K3	=SUM(E3:F3*0.2)
E11	E11	=SUBTOTAL(109,$E$3:$E$10)
F11	F11	=SUBTOTAL(109,$F$3:$F$10)
G11	G11	=SUBTOTAL(109,$G$3:$G$10)
H11	H11	=SUBTOTAL(109,$H$3:$H$10)
I11	I11	=SUBTOTAL(109,$I$3:$I$10)
J11	J11	=SUBTOTAL(109,$J$3:$J$10)
K11	K11	=SUBTOTAL(109,$K$3:$K$10)

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
I3:K10	Expression	=IF(AND(COUNTIF($A$3:$A3,$A3)>1),OR($D3="[xxxx.xlsx]",$D3="[yyyy.xlsx]"))	text	NO
A10,A3:A6,A8	Cell Value	duplicates	text	NO

at work the data is being pulled from different workbooks as opposed to different sheets. All the sheets are named the same ("mmmm yyyy"). Also, after the data has been pulled from the individual sheets, I'd like to paste the Credit Due amount, to the "Credit" column on sheet2 and 3 (The only ones which contain the "Credit" column)

 

[DanteAmor]

Hi Coyotex:

Some notes you should consider:

1. Put the macro in the master book.​

2. The master book sheet is called "Sheet1"​

3. All 5 books must be open.​

4. The name of the book sheet is taken from the master book, from sheet sheet1 in cell B1, in your example the sheet is called "JUNE 2024"​

5. The headers are in row 2 and the data starts in row 3.​

6. At the end you have a row with totals.​

7. Adjust the name of the 5 books on this line:​

bks = Array("book1", "book2", "book3", "book4", "book5")

Try this:

Sub copy_amount()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim dicR As Object, dicC As Object
  Dim shtName As String, col As String
  Dim bks As Variant, bk As Variant, ky As Variant
  Dim i As Long, j As Long, nRow As Long, nCol As Long
  
  Set sh1 = ThisWorkbook.Sheets("Sheet1")
  Set dicR = CreateObject("Scripting.Dictionary")
  Set dicC = CreateObject("Scripting.Dictionary")
  
  shtName = sh1.Range("B1").Value
  bks = Array("book1", "book2", "book3", "book4", "book5")

  For i = 3 To sh1.Range("A" & Rows.Count).End(3).Row - 1
    dicR(sh1.Range("A" & i).Value) = i
  Next
  For j = 5 To sh1.Cells(2, Columns.Count).End(1).Column - 2
    dicC(sh1.Cells(2, j).Value) = j
  Next
  
  For Each bk In bks
    Set sh2 = Workbooks(bk).Sheets(shtName)
    For i = 3 To sh2.Range("A" & Rows.Count).End(3).Row - 1
      
      ky = sh2.Range("A" & i).Value
      If dicR.exists(ky) Then
        nRow = dicR(ky)
      
        If sh2.Range("F2").Value = "Amount Due" Then
          ky = sh2.Range("E" & i).Value
          col = "F"
        Else
          ky = sh2.Range("C1").Value
          col = "E"
        End If
          
        If dicC.exists(ky) Then
          nCol = dicC(ky)
          sh1.Cells(nRow, nCol).Value = sh2.Range(col & i).Value
        End If
      End If
    
    Next
  Next
End Sub

----- --
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
----- --

 

[Coyotex3]

@DanteAmor Thank you for the notes and confirming this one works, and it pulls the right data into the master sheet!

1 Note, this question might be unrelated, and I can start a new thread if needed, In the macro I use at work I use something along these lines

Set LookUp = sht.Rows(2)
    ResultColumn = LookUp.Find("Amount Due", lookat:=xlWhole).Column

Just in case something gets added and the "Amount Due" column move around, the macro can still pull the right data. Although unlikely, the columns might shift around within the sheet. Same with Columns "E" & "F", instead of these columns being fixed could it be made more dynamic? Is this doable in your code?

 

[DanteAmor]

instead of these columns being fixed could it be made more dynamic?

It would be like this:

Sub copy_amount_dinamic()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim dicR As Object, dicC As Object
  Dim shtName As String, col As String
  Dim bks As Variant, bk As Variant, kyRow As Variant, kyCol As Variant
  Dim i As Long, j As Long, nRow As Long, nCol As Long, colAmount As Long
  Dim f As Range
  
  Set sh1 = ThisWorkbook.Sheets("Sheet1")
  Set dicR = CreateObject("Scripting.Dictionary")
  Set dicC = CreateObject("Scripting.Dictionary")
  
  shtName = sh1.Range("B1").Value
  bks = Array("book1", "book2", "book3", "book4", "book5")

  For i = 3 To sh1.Range("A" & Rows.Count).End(3).Row - 1
    dicR(sh1.Range("A" & i).Value) = i
  Next
  For j = 5 To sh1.Cells(2, Columns.Count).End(1).Column - 2
    dicC(sh1.Cells(2, j).Value) = j
  Next
  
  For Each bk In bks
    Set sh2 = Workbooks(bk).Sheets(shtName)
    For i = 3 To sh2.Range("A" & Rows.Count).End(3).Row - 1
      
      kyRow = sh2.Range("A" & i).Value
      If dicR.exists(kyRow) Then
        nRow = dicR(kyRow)
        Set f = sh2.Range("2:2").Find("Credit", , xlValues, xlPart, , , False)
        If Not f Is Nothing Then
          'find "Amount Due" column
          Set f = sh2.Range("2:2").Find("Amount Due", , xlValues, xlWhole, , , False)
          If Not f Is Nothing Then
            colAmount = f.Column
            'find "Items" column
            Set f = sh2.Range("2:2").Find("Items", , xlValues, xlWhole, , , False)
            If Not f Is Nothing Then
              kyCol = sh2.Cells(i, f.Column).Value
              If dicC.exists(kyCol) Then
                nCol = dicC(kyCol)
                sh1.Cells(nRow, nCol).Value = sh2.Cells(i, colAmount).Value
              End If
            End If
          End If
        Else
          'find "Amount Due" column
          Set f = sh2.Range("2:2").Find("Amount Due", , xlValues, xlWhole, , , False)
          If Not f Is Nothing Then
            colAmount = f.Column
            'find "Items" column
            kyCol = sh2.Range("C1").Value
            If dicC.exists(kyCol) Then
              nCol = dicC(kyCol)
              sh1.Cells(nRow, nCol).Value = sh2.Cells(i, colAmount).Value
            End If
          End If
        End If
      End If
    Next
  Next
End Sub

 

[Coyotex3]

Thank you Dante! This is phenomenal. This code is much easier to read than what I had.

One final question on this code.

If an individual sheet had a name repeated twice with different "Amount Due" and I wanted to add up the values, would I need to use a 3rd dictionary to add to sum up the values? Also, can it be done within the existing For Each loop?

 

[DanteAmor]

If an individual sheet had a name repeated twice with different "Amount Due" and I wanted to add up the values

If the name and item are the same, then we accumulate the value in the same cell.
But before executing the macro you must delete the values from the master sheet, since the macro will put the new accumulated values.

Sub copy_amount_dinamic()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim dicR As Object, dicC As Object
  Dim shtName As String, col As String
  Dim bks As Variant, bk As Variant, kyRow As Variant, kyCol As Variant
  Dim i As Long, j As Long, nRow As Long, nCol As Long, colAmount As Long
  Dim f As Range
  
  Set sh1 = ThisWorkbook.Sheets("Sheet1")
  Set dicR = CreateObject("Scripting.Dictionary")
  Set dicC = CreateObject("Scripting.Dictionary")
  
  shtName = sh1.Range("B1").Value
  bks = Array("book1", "book2", "book3", "book4", "book5")

  For i = 3 To sh1.Range("A" & Rows.Count).End(3).Row - 1
    dicR(sh1.Range("A" & i).Value) = i
  Next
  For j = 5 To sh1.Cells(2, Columns.Count).End(1).Column - 2
    dicC(sh1.Cells(2, j).Value) = j
  Next
  
  For Each bk In bks
    Set sh2 = Workbooks(bk).Sheets(shtName)
    For i = 3 To sh2.Range("A" & Rows.Count).End(3).Row - 1
      
      kyRow = sh2.Range("A" & i).Value
      If dicR.exists(kyRow) Then
        nCol = 0
        nRow = dicR(kyRow)
        Set f = sh2.Range("2:2").Find("Credit", , xlValues, xlPart, , , False)
        If Not f Is Nothing Then
          'find "Amount Due" column
          Set f = sh2.Range("2:2").Find("Amount Due", , xlValues, xlWhole, , , False)
          If Not f Is Nothing Then
            colAmount = f.Column
            'find "Items" column
            Set f = sh2.Range("2:2").Find("Items", , xlValues, xlWhole, , , False)
            If Not f Is Nothing Then
              kyCol = sh2.Cells(i, f.Column).Value
              If dicC.exists(kyCol) Then
                nCol = dicC(kyCol)
              End If
            End If
          End If
        Else
          'find "Amount Due" column
          Set f = sh2.Range("2:2").Find("Amount Due", , xlValues, xlWhole, , , False)
          If Not f Is Nothing Then
            colAmount = f.Column
            'find "Items" column
            kyCol = sh2.Range("C1").Value
            If dicC.exists(kyCol) Then
              nCol = dicC(kyCol)
            End If
          End If
        End If
        
        If nCol > 0 Then
          sh1.Cells(nRow, nCol).Value = sh1.Cells(nRow, nCol).Value + sh2.Cells(i, colAmount).Value
        End If
        
      End If
    Next
  Next
End Sub

 

[Coyotex3]

This is unbelievable! Thank you for everything Dante! This is much more than what I had in mind.