VBA- To copy Filtered data to Worksheets in the same workbook

chiswickbridge

Board Regular
Joined
Feb 2, 2013
Messages
124
Hi Guys,

I have a Dynamic data in a sheet named "Data"

Rows 1 to 9 are left empty for Macro Icons. Row 10 is the header ( which has a filter at times or no Filter )

Dynamic Raw but Formatted Data is from A11 to AZ999, consisting of all variables ( Text, Numbers... etc).

Column C ( 11 to 999 ) has the following data ( without any Blanks ), "Active", "Redeemed", "Switched", "Purchase", "Passive", "UnNamed1", "UnNamed2","UnNamed3","UnNamed4" and "UnNamed5". The Unnamed is for future additional filtering.

I can to do this by Advanced filtering, but time consuming as the data changes every week

Need a VBA macro, which can filter by "Active" and create a New Worksheet, and Copy / Paste the formatted data from A11 on wards, and then by "Redeemed" and so forth till "UnNamed5", for the first time.

But the catch is... if "Active" sheet and other sheets are existing ( which will happen the 2nd week ), the VBA must simply Copy / Paste, by clearing the Contents from A11 to AZ199.

Also, the Sheets order will unchanged, namely in the mentioned order as "Active", "Redeemed", "Switched", "Purchase", "Passive", "UnNamed1", "UnNamed2","UnNamed3","UnNamed4" and "UnNamed5"... commencing from the First Sheet in the Woorkbook

Thanks you Guys in Advance for your Help...
 

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.

vcoolio

Well-known Member
Joined
Jun 29, 2014
Messages
1,079
Hello Chiswickbridge,

See if the following works for you:-
VBA Code:
Option Explicit
Sub Test()

        Dim sht As Worksheet, ws As Worksheet, lr As Long, i As Long
        Dim ShID As Object, key As Variant
    
        Set sht = Sheets("Data")
        Set ShID = CreateObject("Scripting.Dictionary")
        lr = sht.Range("A" & Rows.Count).End(xlUp).Row
    
Application.ScreenUpdating = False
Application.DisplayAlerts = False
        
        For i = 11 To lr
              If Not ShID.Exists(sht.Range("C" & i).Value) Then
              ShID.Add sht.Range("C" & i).Value, 1
              End If
        Next i
        
        For Each key In ShID.keys
              If Not Evaluate("ISREF('" & CStr(key) & "'!A1)") Then
              Worksheets.Add(After:=Sheets(Sheets.Count)).Name = key
        End If
        
        Set ws = Sheets(CStr(key))
        ws.UsedRange.Clear
        
        With sht.Range("C10:C" & lr)
              .AutoFilter 1, key
              .EntireRow.Copy ws.[A1]
              .AutoFilter
        End With
               ws.Columns.AutoFit
        Next key

sht.Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Please test it in a copy of your workbook first.

I hope that this helps.

Cheerio,
vcoolio.
 

chiswickbridge

Board Regular
Joined
Feb 2, 2013
Messages
124
Thanks vcoolio...It had worked perfectly...But but....in the added sheets, I wanted the data in cells A11-AZ999 only to be Deleted and pasted. The Area BA11 to BZ999 needs to remain untouched for future Forms or Formulae
 

vcoolio

Well-known Member
Joined
Jun 29, 2014
Messages
1,079
Hello Chiswickbridge,

The code amended as follows should do the task for you:-

VBA Code:
Option Explicit
Sub Test()

        Dim sht As Worksheet, ws As Worksheet, lr As Long, i As Long
        Dim ShID As Object, key As Variant
   
        Set sht = Sheets("Data")
        Set ShID = CreateObject("Scripting.Dictionary")
        lr = sht.Range("A" & Rows.Count).End(xlUp).Row
   
Application.ScreenUpdating = False
Application.DisplayAlerts = False
       
        For i = 11 To lr
              If Not ShID.Exists(sht.Range("C" & i).Value) Then
              ShID.Add sht.Range("C" & i).Value, 1
              End If
        Next i
       
        For Each key In ShID.keys
              If Not Evaluate("ISREF('" & CStr(key) & "'!A1)") Then
              Worksheets.Add(After:=Sheets(Sheets.Count)).Name = key
        End If
       
        Set ws = Sheets(CStr(key))
        ws.Columns("A:AZ").Clear
       
        With sht.[A10].CurrentRegion
              .AutoFilter 3, key
              .Columns("A:AZ").Copy ws.[A1]
              .AutoFilter
        End With
               ws.Columns.AutoFit
        Next key

sht.Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

The data that is transferred to the new destination worksheets is currently pasted starting at cell A1. If you need it pasted starting at cell A10, then change this line of code:-
VBA Code:
.Columns("A:AZ").Copy ws.[A1]

to

VBA Code:
.Columns("A:AZ").Copy ws.[A10]

Again, please test it in a copy of your actual workbook.

I hope that this helps.

Cheerio,
vcoolio.
 
Solution

chiswickbridge

Board Regular
Joined
Feb 2, 2013
Messages
124

ADVERTISEMENT

Your VBA does the job excellently

SORRY, It was my error in not specifying the requirement...

The data is transfered correctly....However, but need a little tweaking due to my mistake... The Headers in the Data sheet is in Row 10 ie from A10:AZ10...This header must also be transfered to all the Added sheets...

In present scenario...I am getting numbers from 1 to 40 appear in the row 10, in all sheets
 

vcoolio

Well-known Member
Joined
Jun 29, 2014
Messages
1,079
Hello Chiswickbridge,

I've attached a mock-up of what I'd assume your workbook generally looks like and the code in post #4 works exactly as it should in the mock-up including the amendment to start with the headings in row 10 of the destination sheets.

You'll find the sample Here.
Click on the button to see how it works.

If it's still not quite working for you then please upload a sample of your workbook to a free file sharing site such as WeTransfer or Drop Box then post the link to your file back here. If your data is sensitive then please use dummy data.

Cheerio,
vcoolio.
 

chiswickbridge

Board Regular
Joined
Feb 2, 2013
Messages
124

ADVERTISEMENT

YESS... It works perfectly on your sample...but not on mine...will check for any errors in formatting and will revert
 

vcoolio

Well-known Member
Joined
Jun 29, 2014
Messages
1,079
That's a start!
I'll be away for a few days but let me know the result of your "investigation".
If you can't find the problem, don't be afraid to upload a sample as per post #6.

Cheerio,
vcoolio.
 

chiswickbridge

Board Regular
Joined
Feb 2, 2013
Messages
124
Have been unable to solve the issue...here is the WeTransfer Link....https://we.tl/t-npSPgSde30
Sometimes the World is so Simple and we look for very difficult solutions...

I Found the Problem....

I had numbered Row 9 - from A9 to AZ9, 1 to 52 to assist in referencing for Vlookup functions.

Your VBA captured this row and pasted it all over. MY MISTAKE...of not Informing you...

Thank you for your efforts and again a Special Thanks for pestering you for the correct solution...
 

Watch MrExcel Video

Forum statistics

Threads
1,129,791
Messages
5,638,340
Members
417,021
Latest member
moon miner

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