View Full Version : Autofilter, copy, paste to new file
Limortz
03-28-2018, 02:14 AM
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.
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
03-29-2018, 05:29 AM
Thanks!
How can I change the save as folder address? since I can't run it like this.
like this.
p = "D:\*****\****"
Limortz
04-01-2018, 12:18 AM
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
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
04-01-2018, 04:30 AM
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!
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
04-03-2018, 01:32 AM
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
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
04-03-2018, 05:03 AM
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
04-16-2018, 12:15 AM
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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.