Previous Topic Next Topic

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
Hi,

I'm still a newbie on VBA, so I could use a little help on getting some code working. I have several client used for factoring. As such, each invoice is sent to the bank at a certain date and I will have monthly interest on each of them (an invoice can pay interest on 1, 2 or even 3 months). The main worksheet has the list of invoices, along with the dates and interests.

The file is this one:
https://www.dropbox.com/s/1v3lxplm8iggpsd/CCM%20test.xlsm?dl=0

So I need some VBA code to:
Create a new work sheet for each new month of interests (when it appears);
Copy all of the invoices in the main worksheet that pay interest in that month, being it the 1st, 2nd or 3rd paying month (without duplicating the data);
Keep all the data in the main worksheet, somehow identifying the copied rows;
Is this possible?

Thanks

7 responses

Answer 1 / 7
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 552
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: 
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
2
Answer 2 / 7
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 552
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: 
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.
2
Answer 3 / 7
fcbarros Posts 4 Registration date Monday September 21, 2015 Status Member Last seen September 30, 2015 1
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!
1
Answer 4 / 7
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 552
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
0

Didn't find the answer you are looking for?

Ask a question
Answer 5 / 7
fcbarros Posts 4 Registration date Monday September 21, 2015 Status Member Last seen September 30, 2015 1
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
0
Answer 6 / 7
fcbarros Posts 4 Registration date Monday September 21, 2015 Status Member Last seen September 30, 2015 1
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
0
Answer 7 / 7
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 552
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:
  • 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
0

Similar discussions

Unlock safe folder without losing any data
Mintu -
HelpiOS -

1 response
AMD data change update new data to DMI
Luis -
dwebb -

1 response
copy a row from one worksheet to another, based on criteria
wy -
vcoolio -

15 responses