I’m a new to VBA and found a macro which does almost what I want but need to be modified. I’ d be very grateful if you could help.
Let’s say I have:
- a workbook called “Source.xlsm” with 30 unique values in col A and 50 other columns fulfilled. First row is filled with column names
ID Name1 Name2 Name…n
A00001 A1 A2 A…n
B00002 B1 B2 B…n

- a workbook called “Dest.xlsm”; formatted file to which I want to copy unique values + all of the columns from “Source.xlsm”


- where in cell “D3” should be value from “Source.xlsm” A2. A1,A2, An…. should be below cell “D3”

I need a macro which will:
- open a “Source.xlsm”
- open “Dest.xlsm”
- loop through all of unique values in col A of “Source.xlsm”
- copy each of unique value to the separate “Dest.xlsm” file where in cell “D3” should be value from “Source.xlsm” A2. A1,A2, A…n should be below cell “D3”
- save the separate files “Dest.xlsm” for each of the unique value from col. A naming for example “A00001_ddmmyyyy.xlsm” where dd-day, mm-month, yyyy-year
- close all files

Macro, which loops through unique values in col A and simply copies these values into separate workbooks instead of copying them into separate “Dest.xlsm” for each of the unique value from col. A

Sub Extract_All_Data_To_New_Workbook()

'this macro assumes that your first row of data is a header row.
'will copy all filtered rows from one worksheet, to another blank workbook
'each unique filtered value will be copied to it's own workbook

'Variables used by the macro
Dim wbDest As Workbook
Dim rngFilter As Range, rngUniques As Range
Dim cell As Range

' Set the filter range (from A1 to the last used cell in column A)
'(Note: you can change this to meet your requirements)
Set rngFilter = Range("A1", Range("A" & Rows.Count).End(xlUp))

Application.ScreenUpdating = False

With rngFilter

' Filter column A to show only one of each item (uniques) in column A
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True

' Set a variable to the Unique values
Set rngUniques = Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisi ble)

' Clear any filter

On Error Resume Next
On Error GoTo 0

End With

' Filter, Copy, and Paste each unique to its own new workbook
For Each cell In rngUniques

' Create a new workbook for each unique value
Set wbDest = Workbooks.Add(xlWBATWorksheet)

'NOTE - this filter is on column A (field:=1), to change
'to a different column you need to change the field number
rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value

' Copy and paste the filtered data to its new workbook
With wbDest.Sheets(1).Range("A1")
.PasteSpecial xlPasteColumnWidths 'Paste column widths
.PasteSpecial xlPasteValuesAndNumberFormats 'Paste values
End With
Application.CutCopyMode = True

' Name the destination sheet
wbDest.Sheets(1).Name = cell.Value

'Save the destination workbook and close
wbDest.SaveAs ThisWorkbook.path & Application.PathSeparator & _
cell.Value & " " & Format(Date, "mmm_dd_yyyy")
wbDest.Close False 'Close the new workbook

Next cell

rngFilter.Parent.AutoFilterMode = False
Application.ScreenUpdating = True

End Sub