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