How To Copy Data Between Several Sheets on VBA

Question

Previous Topic Next Topic

How To Copy Data Between Several Sheets on VBA

Solved/Closed

Report

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

- 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

How To Copy Data Between Several Sheets on VBA
Macro to copy data from one sheet to another based on criteria ✓ - Forum - Excel
How to copy data from one sheet to another in excel using formula - How-To - Excel
How To Copy Data from One Excel Sheet to Another Using a Formula - How-To - Excel
How to auto populate data from multiple sheets to a master ✓ - Forum - Excel
Automatically transfer data from one sheet to another in excel - How-To - Excel

7 replies

Answer 2 / 7

TrowaD

Posts: 2829
Registration date: Sunday September 12, 2010
Status: Moderator
Last seen: November 22, 2021

490
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.

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!

Answer 4 / 7

TrowaD

Posts: 2829
Registration date: Sunday September 12, 2010
Status: Moderator
Last seen: November 22, 2021

490
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

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

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

Answer 7 / 7

TrowaD

Posts: 2829
Registration date: Sunday September 12, 2010
Status: Moderator
Last seen: November 22, 2021

490
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

Ask a question

TrowaD · Accepted Answer · 2015-09-24T11:31:24-0400

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

How To Copy Data Between Several Sheets on VBA

7 replies

Your reply

Subscribe To Our Newsletter!