Copying rows onto new sheet

ArsenalFan1

New Member
Joined
Sep 18, 2006
Messages
8
Hi,

I have a sheet called "Companies"

Information is stored as follows:

LOCATION-----COMPANY------AMOUNT
Edmonton------XYZ------------12
Edmonton------YZ--------------10
Toronto---------XYZ------------13
Toronto---------FAS------------12
Toronto---------EES------------15
Calgary---------EES------------12
Calgary---------XYZ------------13

I want to use VB to do the following:
Copy all rows with Edmonton followed by Calgary into a new sheet (to create itself) called "Alberta"
Copy all rows with Toronto into a sheet called "Ontario"

All your help is very much appreciated.
 

Excel Facts

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)

ArsenalFan1

New Member
Joined
Sep 18, 2006
Messages
8
Oh yeah this button i will have will not be located in the sheet called "Companies" but in another sheet called "Main". Button meaning that i will press the button and it will seperate the sheet itself.

Thanks again.
 

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,305
Office Version
  1. 365
Platform
  1. Windows
Is there a column in the data for the provinces?
 

ArsenalFan1

New Member
Joined
Sep 18, 2006
Messages
8
no we have to search for all rows containing edmonton (which is row 1) and put them in a new sheet called Alberta

then we will search all rows containing calgary and put them in Alberta sheet

Then we will search all rows containing toronto and put them in a new sheet called Ontario.

These are the only 3 cities and only 2 sheets need to be created.
 

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,305
Office Version
  1. 365
Platform
  1. Windows
That's a shame, would have been easier if the provinces were there.

Anyway, try this which assumes the data is in columns A-C starting in row 1.
Code:
Sub DistributeRows()
Dim wsData As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim LastRow As Long
    
    Set wsData = Worksheets("Sheet1")
    LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row
    
    Set wsCrit = Worksheets.Add
    wsCrit.Range("A1") = "LOCATION"
    
    Set wsNew = Worksheets.Add
    wsNew.Name = "Ontario"
        
    wsCrit.Range("A2") = "Toronto"
    wsData.Range("A1:C" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("A1:A2"), CopyToRange:=wsNew.Range("A1")
    
    Set wsNew = Worksheets.Add
    wsNew.Name = "Alberta"

    wsCrit.Range("A2") = "Edmonton"
    wsCrit.Range("A3") = "Calgary"
    wsData.Range("A1:C" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("A1:A3"), CopyToRange:=wsNew.Range("A1")

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

Forum statistics

Threads
1,144,162
Messages
5,722,845
Members
422,460
Latest member
VBA_Noob01

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