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

[Closed]
Report
Posts
1
Registration date
Thursday October 24, 2013
Status
Member
Last seen
October 24, 2013
-
Posts
1864
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
August 7, 2021
-
Here is the data:
A B C
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.

Suggestions?


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

lRow = Range("A" & Rows.Count).End(xlUp).Row
x = 1
Do
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 reply

Posts
1864
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
August 7, 2021
801
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
Workbooks.Add
ActiveWorkbook.SaveAs filename:="C:\Users\systems\Desktop\" & filename & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
'ActiveWorkbook.Worksheets("sheet1").Range("A1").PasteSpecial
wb = ActiveWorkbook.Name
'ActiveWorkbook.Close


nextstep:
wb = cunq.Value
Workbooks.Open wb

filt.Copy

With Workbooks(wb)
.Worksheets("sheet1").Range("a1").PasteSpecial
.Save
.Close
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 (www.excelguru.ca)
'Macro Purpose: Check if a file or folder exists
On Error GoTo EarlyExit
If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True

EarlyExit:
On Error GoTo 0
End Function