Filter and copy&paste by using VBA

[66313282]

Currently, I am doing a report which contains lots of data and I need to filter out each unique account and copy& paste the data to a new/current tab.

Looking to see if someone can help me on this. I will be very appreciate.

What I want the code is to help me to filter each unique account numbers and copy and paste the new/current , so every time I update the "Summary" table and I just need to run the code, and it will do the job for me.

My current code can filter those accounts and create a new tab for each unique account. However, if I update the "Summary" table, the code could not run due to the tab is already existed.


Here is the current code I got so far:


Sub filter()
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim last As Long
Dim sht As String


sht = "Summary"


last = Sheets(sht).Cells(Rows.Count, "T").End(xlUp).Row
Set rng = Sheets(sht).Range("A1:T" & last)

Sheets(sht).Range("T1:T" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True

For Each x In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))

With rng
.AutoFilter
.AutoFilter Field:=20, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy


Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
ActiveSheet.Paste
End With
Next x


Sheets(sht).AutoFilterMode = False

With Application
.CutCopyMode = False
.ScreenUpdating = True
End With

End Sub

 

[Yongle]

Re: Need help on filter and copy&paste by using VBA

I have not tested your code but how about deleting the sheet before creating it like this

Sub filter()
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim last As Long
Dim sht As String

sht = "Summary"

last = Sheets(sht).Cells(Rows.Count, "T").End(xlUp).Row
Set rng = Sheets(sht).Range("A1:T" & last)

Sheets(sht).Range("T1:T" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True

For Each x In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))

    With rng
        .AutoFilter
        .AutoFilter Field:=20, Criteria1:=x.Value
        .SpecialCells(xlCellTypeVisible).Copy
    
[COLOR=#ff0000]        On Error Resume Next
        Application.DisplayAlerts = False
        Sheets(x.Value).Delete
        Application.DisplayAlerts = True
        On Error GoTo 0[/COLOR]
    
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
        ActiveSheet.Paste
    End With
Next x

Sheets(sht).AutoFilterMode = False

With Application
    .CutCopyMode = False
    .ScreenUpdating = True
End With

End Sub

 

[66313282]

Re: Need help on filter and copy&paste by using VBA

Hi Yongle,
First of all, thank you for your time.

I have tried the code that you provided; however, the code does not work when I run the second time(error code 1004).
On the other hand, I will be working on the tabs; therefore, it does not work to delete the existing tabs and creating a new one.

Looking forward for your further suggestions.

 

[Yongle]

Re: Need help on filter and copy&paste by using VBA

I will be working on the tabs; therefore, it does not work to delete the existing tabs and creating a new one

I have NOT tested your code

If you do not want to delete the original sheet, test to see if it exists and add if it does not
- code amended to activate the correct sheet
- your code relied on the sheet being added making it active - which you now do not want to happen every time

    For Each x In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))

        With rng
            .AutoFilter
            .AutoFilter Field:=20, Criteria1:=x.Value
            .SpecialCells(xlCellTypeVisible).Copy
[I][COLOR=#006400]'create sheet if it does not already exist[/COLOR][/I]
            On Error Resume Next
            Debug.Print Sheets(xValue).Name
            If Err.Number = 9 Then Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
            On Error GoTo 0
[I][COLOR=#006400]'activate the sheet[/COLOR][/I]
            Sheets(x.Value).Activate
[I][COLOR=#006400]'paste[/COLOR][/I]
            ActiveSheet.Paste           [COLOR=#ff0000]'???? see my note[/COLOR]
        End With
    Next x

NOTE
I would expect your code to require amending to add values to an existing sheet (without overwriting)
ActiveSheet.Paste will overwrite all previous values if latest range is bigger (or overwrite first few rows if range is smaller)
Does the 2nd paste line up exactly with the first paste? Is all data on the same row?

 

[dmt32]

Re: Need help on filter and copy&paste by using VBA

Hi,
untested but see if this update to your code does what you want

Sub filter()
    
    Dim x As Range
    Dim rng As Range
    Dim last As Long
    Dim sht As Worksheet
    
    
    Set sht = ThisWorkbook.Worksheets("Summary")
    
    last = sht.Cells(sht.Rows.Count, "T").End(xlUp).Row
    
    sht.Range("T1:T" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=sht.Range("AA1"), Unique:=True
    
    Application.ScreenUpdating = False
    For Each x In sht.Range([AA2], sht.Cells(sht.Rows.Count, "AA").End(xlUp))
    
        If Not Evaluate("ISREF('" & x.Value & "'!A1)") Then
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
        Else
            Sheets(x.Value).Cells.ClearContents
        End If
        
    With sht
        .Range("A1").AutoFilter
        Set rng = .Range("A1:T" & last)
        rng.AutoFilter Field:=20, Criteria1:=x.Value
        Set rng = .AutoFilter.Range
    End With
    rng.SpecialCells(xlCellTypeVisible).Copy Sheets(x.Value).Range("A1")
    Set rng = Nothing
    Next x
    
    sht.AutoFilterMode = False
    
    Application.ScreenUpdating = True
    
End Sub

Code checks if sheet already exists & if so, clears previous entry otherwise new sheet added.

Dave

 

[66313282]

Re: Need help on filter and copy&paste by using VBA

Hi dmt32,

Thank You for your time for helping me.
The code that you provided was almost what I wanted; however, the code will delete the exist tab and create a new one.
I will be working aside on each sheet so if I apply this code, it will delete my previous work.

The data(from Summary) goes to each account sheet at the range A:T column as you can see from the code and I will be working aside at column V:AA.
The data can paste the exact range to each sheet and overwrite the previous data but not deleting the exist sheet.
Is it possible to do so?

Thank You once again.

 

[66313282]

Re: Need help on filter and copy&paste by using VBA

Hi Yongle,

I have tried your provided code and it does not work. It keeps adding sheets but without renaming the sheet and pasting the data.

It is fine to overwrite the previous data.
My second paste is pasting the exact range A:T column.

 

[Yongle]

Re: Need help on filter and copy&paste by using VBA

The data can paste the exact range to each sheet and overwrite the previous data but not deleting the exist sheet

What you say tells me that ...
- when data is ADDED to sheet "Summary" it is ALWAYS below all existing data
- rows are NEVER inserted in sheet "Summary"
- most of the data can be amended but the value in column T is NEVER amended

If any of the above is incorrect, then whatever is done in columns V:AA may not NOT line up correctly when data is overwritten

Your original code is modified below to only paste columns A:T and overwrite previous data
- CopyToRange qualified with sheet reference to ensure values are written to correct sheet
- modification not required if code is in the correct sheet module or sheet "Summary" is ALWAYS the active sheet when code is run

Sub Filter()
    Application.ScreenUpdating = False
    Dim x As Range, rng As Range, last As Long, sht As String
    sht = "Summary"

    last = Sheets(sht).Cells(Rows.Count, "T").End(xlUp).Row
    Set rng = Sheets(sht).Range("A1:T" & last)

    Sheets(sht).Range("T1:T" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[COLOR=#ff0000]Sheets(sht)[/COLOR].Range("AA1"), Unique:=True

    For Each x In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))
       [COLOR=#006400][I] 'create sheet if it does not already exist[/I][/COLOR]
            On Error Resume Next
            Debug.Print Sheets(x.Value).Name
            If Err.Number = 9 Then Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
            On Error GoTo 0
       [COLOR=#006400][I] 'filter and copy[/I][/COLOR]
            With rng
                .AutoFilter
                .AutoFilter Field:=20, Criteria1:=x.Value
                .SpecialCells(xlCellTypeVisible).Copy Sheets(x.Value).Range("A1")
            End With
    Next x

    Sheets(sht).AutoFilterMode = False
    
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With

End Sub

 

[dmt32]

Re: Need help on filter and copy&paste by using VBA

Hi dmt32,

Thank You for your time for helping me.
The code that you provided was almost what I wanted; however, the code will delete the exist tab and create a new one.

My code only creates a new sheet if it does not already exist OR clears the previous values for a REFRESH from the summary sheet.

Do you want that data from summary sheet to APPEND to the previous data?

Dave