How To Copy Data Between Several Sheets on VBA
Solved/Closed
fcbarros
TrowaD
- Posts
- 4
- Registration date
- Monday September 21, 2015
- Status
- Member
- Last seen
- September 30, 2015
TrowaD
- Posts
- 2886
- Registration date
- Sunday September 12, 2010
- Status
- Moderator
- Last seen
- June 27, 2022
Related:
- How To Copy Data Between Several Sheets on VBA
- How to copy data from one sheet to another in excel automatically - Guide
- Macro to copy data from one sheet to another based on criteria ✓ - Forum - Excel
- How to auto populate data from multiple sheets to a master ✓ - Forum - Excel
- Macros: Copy Invoice Details From One Sheet to Another ✓ - Forum - Excel
- How to copy cell data from one sheet to another ✓ - Forum - Excel
7 replies
TrowaD
Sep 24, 2015 at 11:31 AM
- Posts
- 2886
- Registration date
- Sunday September 12, 2010
- Status
- Moderator
- Last seen
- June 27, 2022
Sep 24, 2015 at 11:31 AM
Hi Fcbarros,
It might be best to create a copy of your file to see what the code does before going live.
The code will remove all sheets except the "invoices" sheet, as I assumed that the others were all month sheets, that the code will build up again.
The order of the month sheets is the order Interest Payment table shows them. So the first 3 are April, June and May, so that is the order that they are created.
Paste the entire code into a module:
Best regards,
Trowa
It might be best to create a copy of your file to see what the code does before going live.
The code will remove all sheets except the "invoices" sheet, as I assumed that the others were all month sheets, that the code will build up again.
The order of the month sheets is the order Interest Payment table shows them. So the first 3 are April, June and May, so that is the order that they are created.
Paste the entire code into a module:
Sub RunMe() Dim mHeader As Range Dim x, y As Integer Dim sh As Worksheet Application.DisplayAlerts = False For Each sh In Worksheets If sh.Name <> "invoices" Then sh.Delete Next sh Application.DisplayAlerts = True Sheets("invoices").Select Set mHeader = Range("A4:G4") x = 5 y = 11 Do If Sheets("invoices").Cells(x, y).Value <> "N/A" Then If WorksheetExists(Sheets("invoices").Cells(x, y).Value) = False Then Sheets.Add after:=Sheets(Sheets.Count) Sheets(Sheets.Count).Name = Sheets("invoices").Cells(x, y).Value mHeader.Copy Sheets(Sheets.Count).Range("A1") Sheets(Sheets.Count).Range("H1").Value = "Interest" Cells.ColumnWidth = 13 End If Sheets("invoices").Select Sheets("invoices").Range(Cells(x, "A"), Cells(x, "H")).Copy Sheets(Cells(x, y).Value).Select Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Insert Range("A" & Rows.Count).End(xlUp).Offset(0, 7).Value = Sheets("invoices").Cells(x, y).Offset(0, 1) End If x = x + 1 If Sheets("invoices").Cells(x, y) = vbNullString Then y = y + 2 x = 5 End If Loop Until Sheets("invoices").Cells(x, y) = vbNullString And y = 19 End Sub Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean On Error Resume Next WorksheetExists = (Sheets(WorksheetName).Name <> vbNullString) On Error GoTo 0 End Function
Best regards,
Trowa
TrowaD
Sep 28, 2015 at 11:39 AM
- Posts
- 2886
- Registration date
- Sunday September 12, 2010
- Status
- Moderator
- Last seen
- June 27, 2022
Sep 28, 2015 at 11:39 AM
Hi Fcbarros,
Forgot to add the total sum on each month sheet as well as clearing the copy/paste memory.
Here is the adjusted code:
Best regards,
Trowa
Monday, Tuesday and Thursday are usually the days I'll respond. Bear this in mind when awaiting a reply.
Forgot to add the total sum on each month sheet as well as clearing the copy/paste memory.
Here is the adjusted code:
Sub RunMe() Dim mHeader As Range Dim x, y As Integer Dim sh As Worksheet Application.ScreenUpdating = False Application.DisplayAlerts = False For Each sh In Worksheets If sh.Name <> "invoices" Then sh.Delete Next sh Application.DisplayAlerts = True Sheets("invoices").Select Set mHeader = Range("A4:G4") x = 5 y = 11 Do If Sheets("invoices").Cells(x, y).Value <> "N/A" Then If WorksheetExists(Sheets("invoices").Cells(x, y).Value) = False Then Sheets.Add after:=Sheets(Sheets.Count) Sheets(Sheets.Count).Name = Sheets("invoices").Cells(x, y).Value mHeader.Copy Sheets(Sheets.Count).Range("A1") Sheets(Sheets.Count).Range("H1").Value = "Interest" Cells.ColumnWidth = 13 End If Sheets("invoices").Select Sheets("invoices").Range(Cells(x, "A"), Cells(x, "H")).Copy Sheets(Cells(x, y).Value).Select Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Insert Range("A" & Rows.Count).End(xlUp).Offset(0, 7).Value = Sheets("invoices").Cells(x, y).Offset(0, 1) If Range("E" & Rows.Count).End(xlUp).Value <> "Total interest payed in " & ActiveSheet.Name Then Range("E" & Rows.Count).End(xlUp).Offset(2, 0).Value = "Total interest payed in " & ActiveSheet.Name With Range("H" & Rows.Count).End(xlUp).Offset(2, 0) .FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)" .Borders(xlEdgeTop).LineStyle = xlContinuous .Borders(xlEdgeRight).LineStyle = xlContinuous .Borders(xlEdgeBottom).LineStyle = xlContinuous .Borders(xlEdgeLeft).LineStyle = xlContinuous End With End If End If x = x + 1 If Sheets("invoices").Cells(x, y) = vbNullString Then y = y + 2 x = 5 End If Loop Until Sheets("invoices").Cells(x, y) = vbNullString And y = 19 Application.CutCopyMode = False Application.ScreenUpdating = True End Sub Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean On Error Resume Next WorksheetExists = (Sheets(WorksheetName).Name <> vbNullString) On Error GoTo 0 End Function
Best regards,
Trowa
Monday, Tuesday and Thursday are usually the days I'll respond. Bear this in mind when awaiting a reply.
fcbarros
Sep 29, 2015 at 05:05 AM
- Posts
- 4
- Registration date
- Monday September 21, 2015
- Status
- Member
- Last seen
- September 30, 2015
Sep 29, 2015 at 05:05 AM
Thank you very much for your help Trowa!
I do believe you have solved my problem...
I'm currently testing it to make sure it works.
I'll be in touch!
I do believe you have solved my problem...
I'm currently testing it to make sure it works.
I'll be in touch!
TrowaD
Sep 21, 2015 at 11:54 AM
- Posts
- 2886
- Registration date
- Sunday September 12, 2010
- Status
- Moderator
- Last seen
- June 27, 2022
Sep 21, 2015 at 11:54 AM
Hi Fcbarros,
Could you post some month sheets for better understanding of your query and to see how you foresee the end result?
Best regards,
Trowa
Could you post some month sheets for better understanding of your query and to see how you foresee the end result?
Best regards,
Trowa
Didn't find the answer you are looking for?
Ask a question
fcbarros
Sep 21, 2015 at 01:02 PM
- Posts
- 4
- Registration date
- Monday September 21, 2015
- Status
- Member
- Last seen
- September 30, 2015
Sep 21, 2015 at 01:02 PM
Hi Trowa,
Thanks for getting back. I've updated the file, as I foresee a month sheet.
The first invoice was sent to the bank in May, so it will be paying its first month of interest. The others were sent to the bank in april, so in May they will be paying their second month of interest.
https://www.dropbox.com/s/1v3lxplm8iggpsd/CCM%20test.xlsm?dl=0
Cheers
Thanks for getting back. I've updated the file, as I foresee a month sheet.
The first invoice was sent to the bank in May, so it will be paying its first month of interest. The others were sent to the bank in april, so in May they will be paying their second month of interest.
https://www.dropbox.com/s/1v3lxplm8iggpsd/CCM%20test.xlsm?dl=0
Cheers
fcbarros
Sep 30, 2015 at 07:45 AM
- Posts
- 4
- Registration date
- Monday September 21, 2015
- Status
- Member
- Last seen
- September 30, 2015
Sep 30, 2015 at 07:45 AM
Hi Trowa,
the code is working great. Thank you for your help!
Now I'm just trying to fine tune it a bit.
So I'm sending the link of the current file and if it's not too much trouble for you, I would really appreciate your help.
https://www.dropbox.com/s/gyk9dzbwzurkg9b/CCM%20example.xlsm?dl=0
As you can see, the clients names are big, so is there a way to increase just the column A width on each of the interest months?
Also, it would be nice to have the clients sorted, with subtotals of each one's interest...
Cheers
the code is working great. Thank you for your help!
Now I'm just trying to fine tune it a bit.
So I'm sending the link of the current file and if it's not too much trouble for you, I would really appreciate your help.
https://www.dropbox.com/s/gyk9dzbwzurkg9b/CCM%20example.xlsm?dl=0
As you can see, the clients names are big, so is there a way to increase just the column A width on each of the interest months?
Also, it would be nice to have the clients sorted, with subtotals of each one's interest...
Cheers
TrowaD
Oct 1, 2015 at 11:34 AM
- Posts
- 2886
- Registration date
- Sunday September 12, 2010
- Status
- Moderator
- Last seen
- June 27, 2022
Oct 1, 2015 at 11:34 AM
Hi Fcbarros,
Good to see the code is doing it's job.
As for the fine tuning part:
Hopefully the code is doing an even better job now.
Here is the code:
Best regards,
Trowa
Good to see the code is doing it's job.
As for the fine tuning part:
- Column A width has been increased to fit the biggest value in your list.
- Column J now contains a unique client list.
- Column K now contains the subtotals for the client list in column J.
- Column K has been given the same number format as column H
Hopefully the code is doing an even better job now.
Here is the code:
Sub RunMe() Dim mHeader As Range Dim x, y As Integer Dim sh As Worksheet Application.ScreenUpdating = False Application.DisplayAlerts = False For Each sh In Worksheets If sh.Name <> "invoices" Then sh.Delete Next sh Application.DisplayAlerts = True Sheets("invoices").Select Set mHeader = Range("A4:G4") x = 5 y = 11 Do If Sheets("invoices").Cells(x, y).Value <> "N/A" Then If WorksheetExists(Sheets("invoices").Cells(x, y).Value) = False Then Sheets.Add after:=Sheets(Sheets.Count) Sheets(Sheets.Count).Name = Sheets("invoices").Cells(x, y).Value mHeader.Copy Sheets(Sheets.Count).Range("A1") Sheets(Sheets.Count).Range("H1").Value = "Interest" Cells.ColumnWidth = 18 Range("A:A,J:J").ColumnWidth = 47 End If Sheets("invoices").Select Sheets("invoices").Range(Cells(x, "A"), Cells(x, "H")).Copy Sheets(Cells(x, y).Value).Select Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Insert Range("A" & Rows.Count).End(xlUp).Offset(0, 7).Value = Sheets("invoices").Cells(x, y).Offset(0, 1) If Range("E" & Rows.Count).End(xlUp).Value <> "Total interest payed in " & ActiveSheet.Name Then Range("E" & Rows.Count).End(xlUp).Offset(2, 0).Value = "Total interest payed in " & ActiveSheet.Name With Range("H" & Rows.Count).End(xlUp).Offset(2, 0) .FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)" .Borders(xlEdgeTop).LineStyle = xlContinuous .Borders(xlEdgeRight).LineStyle = xlContinuous .Borders(xlEdgeBottom).LineStyle = xlContinuous .Borders(xlEdgeLeft).LineStyle = xlContinuous End With End If End If x = x + 1 If Sheets("invoices").Cells(x, y) = vbNullString Then y = y + 2 x = 5 End If Loop Until Sheets("invoices").Cells(x, y) = vbNullString And y = 19 For Each sh In Worksheets If sh.Name <> "invoices" Then sh.Select Range("A1").CurrentRegion.Sort key1:=Range("A1"), Header:=xlYes Columns("A:A").Copy Columns("J:J") Columns("J:J").RemoveDuplicates Columns:=1, Header:=xlYes Range("K1").Value = "Subtotal" x = 2 Do Cells(x, "K").FormulaR1C1 = "=SUMIF(C[-10]:C[-3],RC[-1],C[-3])" x = x + 1 Loop Until Cells(x, "J") = vbNullString Columns("K:K").NumberFormat = "_-* #,##0.00 $_-;-* #,##0.00 $_-;_-* ""-""?? $_-;_-@_-" End If Next sh Application.CutCopyMode = False Application.ScreenUpdating = True End Sub Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean On Error Resume Next WorksheetExists = (Sheets(WorksheetName).Name <> vbNullString) On Error GoTo 0 End Function
Best regards,
Trowa