How To Copy Data Between Several Sheets on VBA

Solved/Closed
Report
Posts
4
Registration date
Monday September 21, 2015
Status
Member
Last seen
September 30, 2015
-
Posts
2829
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
November 22, 2021
-
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 replies

Posts
2829
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
November 22, 2021
490
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
Thank you

A few words of thanks would be greatly appreciated. Add comment

CCM 2821 users have said thank you to us this month

Posts
2829
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
November 22, 2021
490
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
Thank you

A few words of thanks would be greatly appreciated. Add comment

CCM 2821 users have said thank you to us this month

Posts
4
Registration date
Monday September 21, 2015
Status
Member
Last seen
September 30, 2015
1
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!
Posts
2829
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
November 22, 2021
490
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
Posts
4
Registration date
Monday September 21, 2015
Status
Member
Last seen
September 30, 2015
1
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
Posts
4
Registration date
Monday September 21, 2015
Status
Member
Last seen
September 30, 2015
1
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
Posts
2829
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
November 22, 2021
490
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