How do I create a seperate .XLSM workbook for each list item?

Steve Gardipee Posts 1 Registration date Thursday October 24, 2013 Status Member Last seen October 24, 2013 - Oct 24, 2013 at 10:51 AM
venkat1926 Posts 1863 Registration date Sunday June 14, 2009 Status Contributor Last seen August 7, 2021 - Oct 26, 2013 at 02:55 AM
Here is the data:
1 Data1 Data2 Data3
2 0002 ABC $3.00
3 0002 ABC $4.00
4 0015 YNSD $5.00
5 0032 UYR $6.00

The task is simple, I need to:

(1) create a seperate workbook for each value in Data1 where only "0002"gets populated on the first workbook; "0003" data gets populated on the 2nd workbook, etc. Here there are only three columns, as an EXAMPLE, of data that will transfer. In other words, when the data in column 'Data1" changes, the entire line(s) breaks to a new workbook. There wil be multiple lines of data under "0002", etc.

(2) I also need to bring the column header data into each worksheet (cells A1, B1 and C1)

Here is the code I'm starting with (it does the basic copy to where I want and does the naming); however, per worksheet, I ONLY want to copy UNIQUE DATA1 data - as described above.


Sub CreateWBs()
Dim lRow, x As Integer
Dim wbName As String

lRow = Range("A" & Rows.Count).End(xlUp).Row
x = 1
x = x + 1
wbName = Range("A" & x).Value & "_" & Range("B" & x).Value
ActiveWorkbook.SaveAs Filename:="C:\Sgardipee2 HD\GARDIPEE\Transfer Detail\Union Detail-" & wbName & ".xls"
Loop Until x = lRow

End Sub

1 response

venkat1926 Posts 1863 Registration date Sunday June 14, 2009 Status Contributor Last seen August 7, 2021 811
Oct 26, 2013 at 02:55 AM
data is from A1 to C5

try this macro (I have used the function for the folder exits from that is avalable already in web)

Sub test()
Dim ra As Range, rdata As Range, unq As Range, cunq As Range, filename As String
Dim filt As Range, wb As String
Application.ScreenUpdating = False
With ActiveWorkbook.Worksheets("sheet1")
Range(.Range("A1").End(xlDown).Offset(1, 0), .Cells(Rows.Count, "A")).Cells.Clear
Set ra = Range(.Range("A1"), .Range("A1").End(xlDown))
Set rdata = .Range("A1").CurrentRegion
Set unq = .Range("A1").End(xlDown).Offset(5, 0)
ra.AdvancedFilter xlFilterCopy, , unq, True
Set unq = Range(unq.Offset(1, 0), unq.End(xlDown))
For Each cunq In unq
filename = cunq
rdata.AutoFilter field:=1, Criteria1:=cunq

Set filt = rdata.SpecialCells(xlCellTypeVisible)

On Error GoTo nextstep
If FileFolderExists("c:\users\system\destop\" & filename & ".xlsm") Then GoTo nextstep
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs filename:="C:\Users\systems\Desktop\" & filename & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
wb = ActiveWorkbook.Name

wb = cunq.Value
Workbooks.Open wb


With Workbooks(wb)
End With

.AutoFilterMode = False
Application.CutCopyMode = False
Next cunq
End With

MsgBox "macro over"
Application.ScreenUpdating = True
End Sub

Public Function FileFolderExists(strFullPath As String) As Boolean
'Author : Ken Puls (
'Macro Purpose: Check if a file or folder exists
On Error GoTo EarlyExit
If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True

On Error GoTo 0
End Function