Autofilter, copy, paste to new file

[Limortz]

Hello,

Can anyone help me with some code that canautofilter, copy, and paste to a new sheet that is named after the filteredfield?

Row 1 has column headers and column A containsthe unique values (Names) that I want to filter by. There will be multiple rowscontaining each names. last column for this table is O.

I don't know all of the unique values thatcould be in column A. Is there a way to write the code to make the macro filtereach unique value without knowing what those values are?

I also need it to create a new file and namethe file after the unique value (name) from column A.

Next, it would need to copy the filtered dataand paste it to the newly created file.

It would need to repeat this process untileach unique data set has been copied to its own file.

Thanks for any help.

[mana]

Option Explicit

Sub test()
    Dim r As Range
    Dim c As Range
    Dim p As String
    
    Set r = Range("A1").CurrentRegion
    Set c = r(1).Offset(, r.Columns.Count + 1)
    
    p = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\*****\"
    
    r.Columns(1).AdvancedFilter xlFilterCopy, , c, True
    Do While c.Offset(1).Value <> ""
        With Workbooks.Add(xlWBATWorksheet)
            r.AdvancedFilter xlFilterCopy, c.Resize(2), .Sheets(1).Range("A1")
            .SaveAs p & c.Offset(1).Value & ".xlsx", xlOpenXMLWorkbook
            .Close False
        End With
        c.Offset(1).Delete xlShiftUp
    Loop
    c.Resize(2).ClearContents
    
End Sub

マナ

[Limortz]

Thanks!
How can I change the save as folder address? since I can't run it like this.

[mana]

like this.

p = "D:\*****\****"

[Limortz]

Thank you!
I would like tot take it one step further

I have 2 sheets, in each sheet I want to do the same thing (as mention before) and filter by the same name in both sheets, than copy those 2 sheets to another workbook and save it in that name. and than loop for all.

How Can I add another sheet to that code?

Thanks in advance.
Limor

[mana]

Option Explicit


Sub test2()
    Dim wb As Workbook
    Dim wsT As Worksheet
    Dim ws As Worksheet
    Dim r As Range
    Dim c As Range
    Dim p As String
    
    Set wb = ActiveWorkbook
    wb.Sheets(1).Copy
    Set wsT = ActiveSheet
    
    For Each ws In wb.Worksheets
        If ws.Name <> wsT.Name Then
            ws.Range("A1").CurrentRegion.Offset(1).Copy _
                wsT.Range("A" & Rows.Count).End(xlUp).Offset(1)
        End If
    Next

    Set r = wsT.Range("A1").CurrentRegion
    Set c = r(1).Offset(, r.Columns.Count + 1)
    
    p = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\*****\"
    
    r.Columns(1).AdvancedFilter xlFilterCopy, , c, True
    Do While c.Offset(1).Value <> ""
        With Workbooks.Add(xlWBATWorksheet)
            r.AdvancedFilter xlFilterCopy, c.Resize(2), .Sheets(1).Range("A1")
            .SaveAs p & c.Offset(1).Value & ".xlsx", xlOpenXMLWorkbook
            .Close False
        End With
        c.Offset(1).Delete xlShiftUp
    Loop
    wsT.Parent.Close False
    
End Sub

[Limortz]

Thanks a lot for the quick reply.

It look like a good direction but I would like to keep the data in different sheets, and this code is the data (for each criteria) to one sheet.
I would like that in the final result I will have file with 2 sheets and in each one of those sheets I will get the specific data for each criteria (the criteria should be equal in both shteets- by name)

Could you help me with that?
Thanks!

[mana]

Option Explicit


Sub test3()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim n As Long
    Dim r1 As Range
    Dim r2 As Range
    Dim c As Range
    Dim p As String
    
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    
    n = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = 2
    
    Set r1 = ws1.Range("A1").CurrentRegion
    Set r2 = ws2.Range("A1").CurrentRegion

    Set c = r1(1).Offset(, r1.Columns.Count + 1)
    
    p = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\*****\"
    
    r1.Columns(1).Copy c
    r2.Columns(1).Copy c.Offset(r1.Rows.Count)
    
    c.EntireColumn.RemoveDuplicates 1, vbNo
    
    Do While c.Offset(1).Value <> ""
        With Workbooks.Add
            r1.AdvancedFilter xlFilterCopy, c.Resize(2), .Sheets(1).Range("A1")
            r2.AdvancedFilter xlFilterCopy, c.Resize(2), .Sheets(2).Range("A1")
            .SaveAs p & c.Offset(1).Value & ".xlsx", xlOpenXMLWorkbook
            .Close False
        End With
        c.Offset(1).Delete xlShiftUp
    Loop
    c.Resize(2).ClearContents
    
    Application.SheetsInNewWorkbook = n
    
End Sub

[Limortz]

Option Explicit


Sub test3()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim n As Long
    Dim r1 As Range
    Dim r2 As Range
    Dim c As Range
    Dim p As String
    
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    
    n = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = 2
    
    Set r1 = ws1.Range("A1").CurrentRegion
    Set r2 = ws2.Range("A1").CurrentRegion

    Set c = r1(1).Offset(, r1.Columns.Count + 1)
    
    p = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\*****\"
    
    r1.Columns(1).Copy c
    r2.Columns(1).Copy c.Offset(r1.Rows.Count)
    
    c.EntireColumn.RemoveDuplicates 1, vbNo
    
    Do While c.Offset(1).Value <> ""
        With Workbooks.Add
            r1.AdvancedFilter xlFilterCopy, c.Resize(2), .Sheets(1).Range("A1")
            r2.AdvancedFilter xlFilterCopy, c.Resize(2), .Sheets(2).Range("A1")
            .SaveAs p & c.Offset(1).Value & ".xlsx", xlOpenXMLWorkbook
            .Close False
        End With
        c.Offset(1).Delete xlShiftUp
    Loop
    c.Resize(2).ClearContents
    
    Application.SheetsInNewWorkbook = n
    
End Sub

Wow, amazing you helped me so much !!

I would like to ask you a few additions for this code please:
1. The loop is not ending, it keeps extract files in the list that were already been extracted.
2. I would like to add names for the sheets in the new workbooks.
3 . AutoFit- for the tables in the new workbooks. ( I tried to add the formula "Columns("A:P").entirecolumns.Autofit But it didn't work)

Thanks in advance.

Limor

[mana]

Option Explicit


Sub test4()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim n As Long
    Dim r1 As Range
    Dim r2 As Range
    Dim c As Range
    Dim p As String
    
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    
    n = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = 2
    
    Set r1 = ws1.Range("A1").CurrentRegion
    Set r2 = ws2.Range("A1").CurrentRegion

    Set c = r1(1).Offset(, r1.Columns.Count + 1)
    
    p = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\*****\"
    
    r1.Columns(1).Copy c
    r2.Columns(1).Copy c.Offset(r1.Rows.Count)
    
    c.EntireColumn.RemoveDuplicates 1, xlNo
    
    Do While c.Offset(1).Value <> ""
        With Workbooks.Add
            r1.AdvancedFilter xlFilterCopy, c.Resize(2), .Sheets(1).Range("A1")
            r2.AdvancedFilter xlFilterCopy, c.Resize(2), .Sheets(2).Range("A1")
            .Sheets(1).Name = ws1.Name
            .Sheets(2).Name = ws2.Name
            .Sheets(1).Columns("A:P").AutoFit
            .Sheets(2).Columns("A:P").AutoFit
            .SaveAs p & s & ".xlsx", xlOpenXMLWorkbook
            .Close False
        End With
        c.Offset(1).Delete xlShiftUp
    Loop
    c.Resize(2).ClearContents
    
    Application.SheetsInNewWorkbook = n

End Sub

[Limortz]

Option Explicit


Sub test4()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim n As Long
    Dim r1 As Range
    Dim r2 As Range
    Dim c As Range
    Dim p As String
    
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    
    n = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = 2
    
    Set r1 = ws1.Range("A1").CurrentRegion
    Set r2 = ws2.Range("A1").CurrentRegion

    Set c = r1(1).Offset(, r1.Columns.Count + 1)
    
    p = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\*****\"
    
    r1.Columns(1).Copy c
    r2.Columns(1).Copy c.Offset(r1.Rows.Count)
    
    c.EntireColumn.RemoveDuplicates 1, xlNo
    
    Do While c.Offset(1).Value <> ""
        With Workbooks.Add
            r1.AdvancedFilter xlFilterCopy, c.Resize(2), .Sheets(1).Range("A1")
            r2.AdvancedFilter xlFilterCopy, c.Resize(2), .Sheets(2).Range("A1")
            .Sheets(1).Name = ws1.Name
            .Sheets(2).Name = ws2.Name
            .Sheets(1).Columns("A:P").AutoFit
            .Sheets(2).Columns("A:P").AutoFit
            .SaveAs p & s & ".xlsx", xlOpenXMLWorkbook
            .Close False
        End With
        c.Offset(1).Delete xlShiftUp
    Loop
    c.Resize(2).ClearContents
    
    Application.SheetsInNewWorkbook = n

End Sub

Thank you very very much

[Limortz]

Thank you very very much

Hi again Master
I was trying to add another worksheet to this code but couldn't succeed - when trying to run it says " object variable or with block variable not set" referring to "r3"

Would you mine checking my additions?
thanks!



Public Sub Statement_split()


Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim n As Long
Dim r1 As Range
Dim r2 As Range
Dim r3 As Range
Dim c As Range
Dim p As String

Set ws1 = Worksheets("Overview")
Set ws2 = Worksheets("Renewals List")
Set ws3 = Worksheets("Engagement Table")

n = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 3



Set r1 = ws1.Range("A1").CurrentRegion
Set r2 = ws2.Range("A1").CurrentRegion
Set r3 = ws3.Range("A1").CurrentRegion


Set c = r1(1).Offset(, r1.Columns.Count + 1)

p = "C:\Users\limor.tzach\Google Drive\Commission\2018\Monthly VBA\CSM"


r1.Columns(1).Copy c
r2.Columns(1).Copy c.Offset(r1.Rows.Count)
r3.Columns(1).Copy c.Offset(r1.Rows.Count)



Do While c.Offset(1).Value <> ""
With Workbooks.Add
r1.AdvancedFilter xlFilterCopy, c.Resize(2), .Sheets(1).Range("A1")
r2.AdvancedFilter xlFilterCopy, c.Resize(2), .Sheets(2).Range("A1")
r3.AdvancedFilter xlFilterCopy, c.Resize(2), .Sheets(3).Range("A1")
.Sheets(1).Name = ws1.Name
.Sheets(2).Name = ws2.Name
.Sheets(3).Name = ws3.Name
.Sheets(1).Columns("A:P").AutoFit
.Sheets(2).Columns("A:P").AutoFit
.Sheets(3).Columns("A:P").AutoFit
.SaveAs p & c.Offset(1).Value & ".xlsx", xlOpenXMLWorkbook
.Close False
End With
c.Offset(1).Delete xlShiftUp
Loop
c.Resize(2).ClearContents

Application.SheetsInNewWorkbook = n


End Sub