Vba code needed to create workbooks based on column data

[pcloukas]

Good evening everyone,

I'm new to VBA and i need a simple VBA code to split a sheet into new workbooks based on data in column F (Date), so i can create several workbooks based on date.

TYPE	Loc	Code	Area	Source	Date
ZUST	1233	277884	3	3333	20230216
ZUST	1233	277886	3	3333	20230217
ZUST	1233	277887	2	3333	20230216
ZUST	1233	277888	1	3333	20230218
ZUST	1233	277900	3	3333	20230217

The new workbooks would be helpful to store in the folder where the main workbook is saved



Can anyone help?

 

[pcloukas]

There isn't a reply associated with your last post!

Cheerio,
vcoolio.

Good morning my friend, i'm trying to setup the add in in order to see the file correct, but although i did it i cant find it in the ribbon

 

[pcloukas]

I actually did test it this time and it works just fine on my end. Perhaps upload a sample of the worksheet that you are working from using the XL2BB uploader noted at the top of any reply box.

Cheerio,
vcoolio.

I actually did test it this time and it works just fine on my end. Perhaps upload a sample of the worksheet that you are working from using the XL2BB uploader noted at the top of any reply box.

Cheerio,
vcoolio.

I actually did test it this time and it works just fine on my end. Perhaps upload a sample of the worksheet that you are working from using the XL2BB uploader noted at the top of any reply box.

Cheerio,
vcoolio.

ZUST RIVER.xlsx
	A	B	C	D	E	F
1	Doc type	Target	Article	Qty	Source	Date
2	ZUST	1233	277884	3	9099	20230216
3	ZUST	1233	277886	3	9099	20230216
4	ZUST	1233	277887	2	9099	20230216
5	ZUST	1233	277888	1	9099	20230216
6	ZUST	1233	277900	3	9099	20230216
7	ZUST	1233	277902	3	9099	20230216
8	ZUST	1233	277905	2	9099	20230216
9	ZUST	1233	277906	2	9099	20230216
10	ZUST	1233	277909	2	9099	20230216
11	ZUST	1233	277910	2	9099	20230216
12	ZUST	1233	277914	2	9099	20230216
13	ZUST	1233	277915	3	9099	20230216
14	ZUST	1233	277918	3	9099	20230216
Sheet1

 

[vcoolio]

Hello PcLoukas,

Your dates are all the same.
In your workbook, are they actual dates or are they formatted as text?

Cheerio,
vcoolio.

 

[pcloukas]

Hello PcLoukas,

Your dates are all the same.
In your workbook, are they actual dates or are they formatted as text?

Cheerio,
vcoolio.

You are correct, you can use if you like 2 different dates for the test. The date is custom format yyyymmdd

 

[vcoolio]

Hello PcLoukas,

Try the following amended code:-

Option Explicit
Sub TestWbks()

        Dim i As Long, mypath As String, ar As Variant, sh As Worksheet, lr As Long

Application.ScreenUpdating = False
Application.DisplayAlerts = False

        mypath = ThisWorkbook.Path & "\"
        Set sh = ThisWorkbook.Sheets("Sheet1")
        lr = sh.Range("A" & Rows.Count).End(xlUp).Row
        sh.Range("F1:F" & lr).AdvancedFilter 2, , sh.[X1], 1  'Unique values moved temporarily to Column X.
        sh.Range("X2", sh.Range("X" & sh.Rows.Count).End(xlUp)).Sort [X2], 1 'Unique values sorted.
        ar = sh.Range("X2", sh.Range("X" & sh.Rows.Count).End(xlUp))
        
        For i = 1 To UBound(ar)
                If Not Evaluate("ISREF('" & CStr(ar(i, 1)) & "'!A1)") Then
                        Workbooks.Add
                        ActiveWorkbook.SaveAs mypath & CStr(ar(i, 1)) & ".xlsx"
                        ActiveWorkbook.Close
                End If
        Next i
        sh.Columns(24).Clear
        
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

I've added a couple of more lines of code. You'll see them with comments after them (green font). They basically extract the unique values from Column F, using the Advanced Filter and temporarily move them to Column X where they are sorted then placed into an array from where the code will create the new workbooks. This should help to speed things up for you. Column X is then cleared.

I hope that this helps.

Cheerio,
vcoolio.

 

[pcloukas]

Hello PcLoukas,

Try the following amended code:-

Option Explicit
Sub TestWbks()

        Dim i As Long, mypath As String, ar As Variant, sh As Worksheet, lr As Long

Application.ScreenUpdating = False
Application.DisplayAlerts = False

        mypath = ThisWorkbook.Path & "\"
        Set sh = ThisWorkbook.Sheets("Sheet1")
        lr = sh.Range("A" & Rows.Count).End(xlUp).Row
        sh.Range("F1:F" & lr).AdvancedFilter 2, , sh.[X1], 1  'Unique values moved temporarily to Column X.
        sh.Range("X2", sh.Range("X" & sh.Rows.Count).End(xlUp)).Sort [X2], 1 'Unique values sorted.
        ar = sh.Range("X2", sh.Range("X" & sh.Rows.Count).End(xlUp))
       
        For i = 1 To UBound(ar)
                If Not Evaluate("ISREF('" & CStr(ar(i, 1)) & "'!A1)") Then
                        Workbooks.Add
                        ActiveWorkbook.SaveAs mypath & CStr(ar(i, 1)) & ".xlsx"
                        ActiveWorkbook.Close
                End If
        Next i
        sh.Columns(24).Clear
       
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

I've added a couple of more lines of code. You'll see them with comments after them (green font). They basically extract the unique values from Column F, using the Advanced Filter and temporarily move them to Column X where they are sorted then placed into an array from where the code will create the new workbooks. This should help to speed things up for you. Column X is then cleared.

I hope that this helps.

Cheerio,
vcoolio.

Thank you for your effort coolio, it stops here

 

[vcoolio]

Hello PcLoukas,

Dates can be somewhat painful to work with but try the following amended code:-

Option Explicit
Sub TestWbks()

        Dim i As Long, mypath As String, ar As Variant, sh As Worksheet, lr As Long

Application.ScreenUpdating = False

        mypath = ThisWorkbook.Path & "\"
        Set sh = ThisWorkbook.Sheets("Sheet1")
        sh.Range("W1") = "Unique"
        lr = sh.Range("A" & Rows.Count).End(xlUp).Row
        sh.Range("W2:W" & lr) = "=CONCAT(YEAR(F2),MONTH(F2),DAY(F2))"
        sh.Range("W1:W" & lr).AdvancedFilter 2, , sh.[X1], 1
        sh.Range("X2", sh.Range("X" & sh.Rows.Count).End(xlUp)).Sort [X2], 1
        ar = sh.Range("X2", sh.Range("X" & sh.Rows.Count).End(xlUp))
        
        For i = 1 To UBound(ar)
                If Not Evaluate("ISREF('" & ar(i, 1) & "'!A1)") Then
                        Workbooks.Add
                        ActiveWorkbook.SaveAs mypath & ar(i, 1) & ".xlsx"
                        ActiveWorkbook.Close
                End If
        Next i
        sh.Columns("W:X").Clear
        
Application.ScreenUpdating = True

End Sub

Now we're using two helper columns temporarily, W and X. In Column W, a formula extracts the year, month and day from your custom format in Column F. Column W is then automatically formatted as "General", the default. From this column, the Advanced Filter will extract the unique values and place them into Column X and sort them. The values are then placed into an array as per my previous code. From there the code does the rest and creates the new workbooks.

The sample that you posted in post #12 only has one date so I added a few more to test with and the code worked without any problems. I'd assume that your data has more than one date because, if it hasn't, the code will error due to the fact that an array will not work in such a situation with only one element included.

I hope that this helps.

Cheerio,
vcoolio.