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

[chiswickbridge]

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

 

[vcoolio]

Hello Chiswickbridge,

See if the following works for you:-

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]

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]

Hello Chiswickbridge,

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

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:-

.Columns("A:AZ").Copy ws.[A1]

to

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

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

I hope that this helps.

Cheerio,
vcoolio.

 

[chiswickbridge]

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]

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]

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

 

[vcoolio]

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]

Have been unable to solve the issue...here is the WeTransfer Link....https://we.tl/t-npSPgSde30

 

[chiswickbridge]

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