Macro To Copy & Paste To Sheets

crashing1912

New Member
Joined
Sep 8, 2011
Messages
19
Hi all,

I have a master sheet of billing information with 1,000 lines of data for 30 different clients and I have 30 sheets with the names of each client as the sheet name. I need a macro, which will copy and paste each client's information from the master sheet into the client's worksheet five lines below the last entry. In addition, I need the macro to add a new sheet if the client name is not one of the client sheets. Below, I put what code I have, but over the past week of trying to figure this out, I can't really say how useful it is any more. I greatly appreciate any help on this. Let me know if you need anymore information. Thanks!

Sub Copyandpaste ()

Dim wsAll As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim LastRow2 As Long
Dim LastRowCrit As Long
Dim I As Long
Dim FindLastRow As Long
Dim sh As Worksheet

Set wsAll = Worksheets("All") ' change All to the name of the worksheet the existing data is on

LastRow2 = wsAll.Range("A" & Rows.count).End(xlUp).Row
FindLastRow = Range("A65536").End(xlUp).Row

Set wsCrit = Worksheets.Add

' column A has the criteria
wsAll.Range("B1:B" & LastRow2).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
LastRowCrit = wsCrit.Range("A" & Rows.count).End(xlUp).Row



For Each sh In ActiveWorkbook.Worksheets
If wsCrit.Range("A2") <> sh.Name Then
wsAll.Rows("1:" & LastRow2).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("A1:A2"), _
CopyToRange:=ws.Range("A1"), Unique:=False
wsCrit.Rows(2).Delete

Next sh

Else
For I = 2 To LastRowCrit
Set wsNew = Worksheets.Add
wsNew.Name = wsCrit.Range("A2")
wsAll.Rows("1:" & LastRow2).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("A1:A2"), _
CopyToRange:=wsNew.Range("A1"), Unique:=False
wsCrit.Rows(2).Delete

Next I

Application.DisplayAlerts = False
wsCrit.Delete
Application.DisplayAlerts = True

End If

End Sub
 

Some videos you may like

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).

AlphaFrog

MrExcel MVP
Joined
Sep 2, 2009
Messages
16,384
<font face=Courier New><SPAN style="color:#00007F">Sub</SPAN> Copyandpaste()<br><br>    <SPAN style="color:#00007F">Dim</SPAN> wsAll       <SPAN style="color:#00007F">As</SPAN> Worksheet<br>    <SPAN style="color:#00007F">Dim</SPAN> wsClient    <SPAN style="color:#00007F">As</SPAN> Worksheet<br>    <SPAN style="color:#00007F">Dim</SPAN> LastRow     <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> rngClients  <SPAN style="color:#00007F">As</SPAN> Range<br>    <SPAN style="color:#00007F">Dim</SPAN> Client      <SPAN style="color:#00007F">As</SPAN> Range<br>    <br>    Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN><br><br>    <SPAN style="color:#00007F">Set</SPAN> wsAll = Worksheets("All")    <SPAN style="color:#007F00">' change All to the name of the worksheet the existing data is on</SPAN><br>    LastRow = wsAll.Range("B" & Rows.Count).End(xlUp).Row<br>    <br>    wsAll.Range("B1:B" & LastRow).AdvancedFilter Action:=xlFilterInPlace, Unique:=<SPAN style="color:#00007F">True</SPAN><br>    <SPAN style="color:#00007F">Set</SPAN> rngClients = wsAll.Range("B2:B" & LastRow).SpecialCells(xlCellTypeVisible)<br>    <SPAN style="color:#00007F">If</SPAN> wsAll.FilterMode <SPAN style="color:#00007F">Then</SPAN> wsAll.ShowAllData<br>    <br>    <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> Client <SPAN style="color:#00007F">In</SPAN> rngClients<br>        <SPAN style="color:#00007F">If</SPAN> Client.Value <> "" <SPAN style="color:#00007F">Then</SPAN><br>        <br>            <SPAN style="color:#00007F">Set</SPAN> wsClient = <SPAN style="color:#00007F">Nothing</SPAN><br>            <SPAN style="color:#00007F">On</SPAN> <SPAN style="color:#00007F">Error</SPAN> <SPAN style="color:#00007F">Resume</SPAN> <SPAN style="color:#00007F">Next</SPAN><br>                <SPAN style="color:#00007F">Set</SPAN> wsClient = Sheets(Client.Text)<br>            <SPAN style="color:#00007F">On</SPAN> <SPAN style="color:#00007F">Error</SPAN> <SPAN style="color:#00007F">GoTo</SPAN> 0<br>            <SPAN style="color:#00007F">If</SPAN> wsClient <SPAN style="color:#00007F">Is</SPAN> <SPAN style="color:#00007F">Nothing</SPAN> <SPAN style="color:#00007F">Then</SPAN><br>                <SPAN style="color:#00007F">Set</SPAN> wsClient = Sheets.Add(After:=Sheets(Sheets.Count))<br>                wsClient.Name = Client.Text<br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>            <br>            wsAll.Range("B1:B" & LastRow).AutoFilter Field:=1, Criteria1:=Client.Value<br>            <br>            wsAll.Range("2:" & LastRow).SpecialCells(xlCellTypeVisible).Copy _<br>                Destination:=wsClient.Range("A" & Rows.Count).End(xlUp).Offset(5)<br>                <br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <SPAN style="color:#00007F">Next</SPAN> Client<br>    wsAll.AutoFilterMode = <SPAN style="color:#00007F">False</SPAN><br>    Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN><br><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>
 

crashing1912

New Member
Joined
Sep 8, 2011
Messages
19
Exactly what I needed. Thank you very much AlphaFrog, especially for the quick response! You saved the day!
 

voyama

New Member
Joined
Apr 12, 2012
Messages
4
I made use of this code and it works amazing. May I ask for advise on slight change:

In my main sheet, I have 2 columns, client phone number and client name. Code creates new sheet for each of my clients and copies the data. What I am looking is the code to copy to the new sheet only the values from Column A (phone numbers).

Ex:
Column A Column B
555-123-1234 Client A
555-234-1234 Client B
555-999-0987 Client A

System will copy only corresponding values from column A to the new worksheet.

Thank you very much
 

AlphaFrog

MrExcel MVP
Joined
Sep 2, 2009
Messages
16,384

ADVERTISEMENT

Change this...
Code:
            wsAll.Range("[COLOR="Blue"]2:[/COLOR]" & LastRow).SpecialCells(xlCellTypeVisible).Copy _
                Destination:=wsClient.Range("A" & Rows.Count).End(xlUp).Offset(5)

To this...
Code:
            wsAll.Range("[COLOR="Red"]A2:A[/COLOR]" & LastRow).SpecialCells(xlCellTypeVisible).Copy _
                Destination:=wsClient.Range("A" & Rows.Count).End(xlUp).Offset(5)
 

voyama

New Member
Joined
Apr 12, 2012
Messages
4
You are the BEST!!!! Thank you so much for a very fast reply. I am a beginner into Excel VBA and have lots to learn. These examples are great help in my learning journey. Thank you again.
 

AlphaFrog

MrExcel MVP
Joined
Sep 2, 2009
Messages
16,384

ADVERTISEMENT

You're welcome and thanks for the feedback.
 

voyama

New Member
Joined
Apr 12, 2012
Messages
4
If I may ask one more question. I have added 3 lines of code to the body so that after copying data to new sheet, it will save as that sheet as csv file and name it same as name of the sheet.

Code:
            wsAll.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).Copy _
                Destination:=wsClient.Range("A" & Rows.Count).End(xlUp).Offset(1)
            
           [COLOR="Red"] wsClient.Activate
            wsClient.SaveAs Filename:=ThisWorkbook.Path & "\" & wsClient.Name, FileFormat:=xlCSV, CreateBackup:=False
            wsClient.Close SaveChanges:=True[/COLOR]

It is working well except 1 little strange behavior. Basically my workbook gets replaced with last customer csv file. So I have my file called "List.xlsm" and within that I have my main sheet called "ContactList" and a button to run the macro. When I click the button, it runs, all client sheets gets created, the csv files get created. My last client in the list is Masons. So my active list.xlsm gets replaced with Masons.csv. If I do not save as, then my list.xlsm file is back to original stage and does not have new sheets with client namess.
 

AlphaFrog

MrExcel MVP
Joined
Sep 2, 2009
Messages
16,384
Code:
            [color=green]'Save worksheet as CSV[/color]
            wsClient.Copy   [color=green]'copies the worksheet as a new workbook[/color]
            ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & wsClient.Name, FileFormat:=xlCSV, CreateBackup:=[color=darkblue]False[/color]
            ActiveWorkbook.Close SaveChanges:=[color=darkblue]False[/color]
            
            [color=green]'Delete worksheet[/color]
            Application.DisplayAlerts = [color=darkblue]False[/color]
                wsClient.Delete
            Application.DisplayAlerts = [color=darkblue]True[/color]
 

Watch MrExcel Video

Forum statistics

Threads
1,122,987
Messages
5,599,210
Members
414,296
Latest member
nachname

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top