How To Copy Data Between Several Sheets on VBA
Solved/Closed
fcbarros
Posts
4
Registration date
Monday September 21, 2015
Status
Member
Last seen
September 30, 2015
-
Sep 21, 2015 at 06:47 AM
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 - Oct 1, 2015 at 11:34 AM
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 - Oct 1, 2015 at 11:34 AM
Related:
- How To Copy Data Between Several Sheets on VBA
- Vba case like - Guide
- Tmobile data check - Guide
- Sheets right to left - Guide
- Number to words in excel formula without vba - Guide
- Transfer data from one excel worksheet to another automatically - Guide
7 responses
TrowaD
Posts
2921
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
December 27, 2022
552
Sep 24, 2015 at 11:31 AM
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
Posts
2921
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
December 27, 2022
552
Sep 28, 2015 at 11:39 AM
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
Posts
4
Registration date
Monday September 21, 2015
Status
Member
Last seen
September 30, 2015
1
Sep 29, 2015 at 05:05 AM
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
Posts
2921
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
December 27, 2022
552
Sep 21, 2015 at 11:54 AM
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
Posts
4
Registration date
Monday September 21, 2015
Status
Member
Last seen
September 30, 2015
1
Sep 21, 2015 at 01:02 PM
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
Posts
4
Registration date
Monday September 21, 2015
Status
Member
Last seen
September 30, 2015
1
Sep 30, 2015 at 07:45 AM
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
Posts
2921
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
December 27, 2022
552
Oct 1, 2015 at 11:34 AM
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