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?

C

Coyotex3

Well-known Member
Joined
Dec 12, 2021
Messages
507
Office Version
  1. 365
Platform
  1. Windows
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
ABCDEFGHIJ
1A SuiteJun-24
2NameCountryCityTypeMineralsGamesTVToysShoesTotal
3AllucarUSANYCReturn0
4DianeJPTokyoNew0
5HelenCANVancouverNew0
6RadahnGERHamburgNew0
7RennahUSASeattleReturn0
8AlexanderUSAFairfaxNew0
9TyUSANYCNew0
10BayleJPTokyoReturn0
Sheet1 (2)
Cell Formulas
RangeFormula
J3:J10J3=SUM(E3:I3)


And these five individual sheets:

Book3
ABCDEFG
1A SuiteJun-24
2NameCountryCityTypeItem AAmount DueCredit
3EmilyUSANYCReturnCars119630
4JaneJPTokyoNewClothing120170
5HelenCANVancouverNewMinerals111510
6DianeGERHamburgNewGames105160
7JessUSASeattleReturnGames126880
Sheet2


Book3
ABCDEFG
1A SuiteJun-24
2NameCountryCityTypeItem AAmount DueCredit
3RanniUSANYCReturnCars100000
4RadahnJPTokyoNewClothing100000
5RennahCANVancouverNewMinerals100000
6FiaGERHamburgNewGames100000
Sheet3


Book3
ABCDE
1A SuiteJun-24Toys
2NameCountryCityTypeAmount Due
3BlakeUSANYCReturn500
4ClayJPTokyoNew300
5TyCANVancouverNew400
6JohnGERHamburgNew200
Sheet5


Book3
ABCDE
1A SuiteJun-24Toys
2NameCountryCityTypeAmount Due
3BlakeUSANYCReturn500
4ClayJPTokyoNew300
5TyCANVancouverNew400
6JohnGERHamburgNew200
Sheet5


Book3
ABCDE
1A SuiteJun-24Shoes
2NameCountryCityTypeAmount Due
3BlaineUSANYCReturn100
4AllucarJPTokyoNew500
5BayleCANVancouverNew350
6DianeCANVancouverNew200
7HelenCANVancouverNew200
Sheet6

And I'd like to get to this:

Book3
ABCDEFGHIJ
1A SuiteJun-24
2NameCountryCityTypeMineralsGamesTVToysShoesTotal
3AllucarUSANYCReturn0050000500
4DianeJPTokyoNew1051600020010716
5HelenCANVancouverNew1215100020012351
6RadahnGERHamburgNew01000000010000
7RennahUSASeattleReturn01000000010000
8AlexanderUSAFairfaxNew0002000200
9TyUSANYCNew000000
10BayleJPTokyoReturn0000350350
She1
Cell Formulas
RangeFormula
J3:J10J3=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.

VBA Code: 
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
.
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
Sort by date Sort by votes
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
ABCDEFGHIJK
1Master SheetJune 2024Service
2NameCountryID#SheetMineralsGamesTVToysShoesTotalCredit Due
3AllucarUSA1xxxx--
4DianeJP2xxxx--
5HelenCAN3xxxx--
6FiaGER4yyyy--
7RennahUSA5yyyy--
8AlexanderUSA6yyyy--
9TyUSA7yyyy--
10BayleJP8xxxx--
11Totals-------
1
Cell Formulas
RangeFormula
J3:J10J3=SUM(E3:I3)
K3:K10K3=SUM(E3:F3*0.2)
E11E11=SUBTOTAL(109,$E$3:$E$10)
F11F11=SUBTOTAL(109,$F$3:$F$10)
G11G11=SUBTOTAL(109,$G$3:$G$10)
H11H11=SUBTOTAL(109,$H$3:$H$10)
I11I11=SUBTOTAL(109,$I$3:$I$10)
J11J11=SUBTOTAL(109,$J$3:$J$10)
K11K11=SUBTOTAL(109,$K$3:$K$10)
Cells with Conditional Formatting
CellConditionCell FormatStop If True
I3:K10Expression=IF(AND(COUNTIF($A$3:$A3,$A3)>1),OR($D3="[yyyy.xlsx]",$D3="[xxxx.xlsx]"))textNO
A10,A3:A6,A8Cell ValueduplicatestextNO


Here are the workbooks I'm pulling data from



Test Sample.xlsx
ABCDEFG
1Team AJune 2024
2NameCountryCityIDItemsAmount DueCredit
3EmilyUSANYC10Cars119630
4JaneJPTokyo11Clothing120170
5HelenCANVancouver12Minerals111510
6DianeGERHamburg13Games105160
7JessUSASeattle14Games126880
8Totals58,335.00-
2
Cell Formulas
RangeFormula
F8:G8F8=SUM(F3:F7)
Cells with Conditional Formatting
CellConditionCell FormatStop If True
A3:A7Expression=AND(ISNUMBER(#REF!),#REF!<1)textNO


Test Sample.xlsx
ABCDEFG
1Team BJune 2024
2NameCountryCityIDItemsAmount DueCredit
3RanniUSANYC14Cars100000
4RadahnJPTokyo15Clothing100000
5RennahCANVancouver16Minerals100000
6RennahCANVancouver17Games100000
7FiaGERHamburg17Games100000
8Totals50,000.00-
3
Cell Formulas
RangeFormula
F8:G8F8=SUM(F3:F7)
Cells with Conditional Formatting
CellConditionCell FormatStop If True
A3:A7Expression=AND(ISNUMBER(#REF!),#REF!<1)textNO


Test Sample.xlsx
ABCDE
1Team CJune 2024Shoes
2NameCountryCityIDAmount Due
3BlaineUSANYC17100
4AllucarJPTokyo18500
5BayleCANVancouver19350
6DianeCANVancouver20200
7HelenCANVancouver21200
8Total1350
4
Cell Formulas
RangeFormula
E8E8=SUM(E3:E7)
Cells with Conditional Formatting
CellConditionCell FormatStop If True
A3:A6,A8Expression=AND(ISNUMBER(#REF!),#REF!<1)textNO


Test Sample.xlsx
ABCDE
1Team DJune 2024Toys
2NameCountryCityIDAmount Due
3BlakeUSANYC22500
4ClayJPTokyo23300
5TyCANVancouver24400
6JohnGERHamburg25200
7AlexanderJPOsaka26200
8Total1600
5
Cell Formulas
RangeFormula
E8E8=SUM(E3:E7)
Cells with Conditional Formatting
CellConditionCell FormatStop If True
A3:A6,A8Expression=AND(ISNUMBER(#REF!),#REF!<1)textNO


Test Sample.xlsx
ABCDE
1Team EJune 2024TV
2NameCountryCityIDAmount Due
3FiaUSANYC22500
4Total500
6
Cell Formulas
RangeFormula
E4E4=SUM(E3:E3)
Cells with Conditional Formatting
CellConditionCell FormatStop If True
A3:A4Expression=AND(ISNUMBER(#REF!),#REF!<1)textNO


And here is the expected result:
Test Sample.xlsx
ABCDEFGHIJK
1Master SheetJune 2024Service
2NameCountryID#SheetMineralsGamesTVToysShoesTotalCredit Due
3AllucarUSA1xxxx500.00500.00-
4DianeJP2xxxx10,516.00200.0010,716.002,103.20
5HelenCAN3xxxx11,151.00200.0011,351.002,230.20
6FiaGER4yyyy10,000.00500.0010,500.002,000.00
7RennahUSA5yyyy10,000.0010,000.0020,000.004,000.00
8AlexanderUSA6yyyy200.00200.00-
9TyUSA7yyyy400.00400.00-
10BayleJP8xxxx350.00350.00-
11Totals21,151.0030,516.00500.00600.001,250.0054,017.0010,333.40
7
Cell Formulas
RangeFormula
J3:J10J3=SUM(E3:I3)
K3:K10K3=SUM(E3:F3*0.2)
E11E11=SUBTOTAL(109,$E$3:$E$10)
F11F11=SUBTOTAL(109,$F$3:$F$10)
G11G11=SUBTOTAL(109,$G$3:$G$10)
H11H11=SUBTOTAL(109,$H$3:$H$10)
I11I11=SUBTOTAL(109,$I$3:$I$10)
J11J11=SUBTOTAL(109,$J$3:$J$10)
K11K11=SUBTOTAL(109,$K$3:$K$10)
Cells with Conditional Formatting
CellConditionCell FormatStop If True
I3:K10Expression=IF(AND(COUNTIF($A$3:$A3,$A3)>1),OR($D3="[xxxx.xlsx]",$D3="[yyyy.xlsx]"))textNO
A10,A3:A6,A8Cell ValueduplicatestextNO


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)
 
Last edited:
Upvote 0
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:​
VBA Code: 
bks = Array("book1", "book2", "book3", "book4", "book5")

Try this:
VBA Code: 
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
----- --
 
Upvote 1
@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

VBA Code: 
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?
 
Upvote 1
Coyotex3 said:
instead of these columns being fixed could it be made more dynamic?
Click to expand...
It would be like this:

VBA Code: 
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

🫡
 
Upvote 1
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?
 
Upvote 0
Coyotex3 said:
If an individual sheet had a name repeated twice with different "Amount Due" and I wanted to add up the values
Click to expand...
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.


VBA Code: 
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
 
Upvote 0
Solution
This is unbelievable! Thank you for everything Dante! This is much more than what I had in mind.
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
VBA Copy/Paste from different workbooks
Replies
1
Views
359
NdNoviceHlp
NdNoviceHlp
C
  • Solved
User Select PDF import to specific Excel sheet
2 3 4
Replies
31
Views
1K
John_w
J
G
  • Solved
Filter VBA to sheets
Replies
8
Views
634
gleamng
G
T
  • Solved
Help with VBA Code in Excel
Replies
2
Views
299
tixarah
T
Agnarr
  • Question Question
VBA problem with creating new sheets
Replies
0
Views
810
Agnarr
Agnarr

Forum statistics

Threads
1,223,703
Messages
6,173,973
Members
452,540
Latest member
haasro02

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top