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?

 

[vcoolio]

Hello PcLoukas,

See if this helps (untested):-

Option Explicit
Sub TestWbks()

        Dim i As Long, mypath As String, ar As Variant

Application.ScreenUpdating = False
Application.DisplayAlerts = False

        mypath = ThisWorkbook.Path & "\"
        ar = sh.Range("F2", sh.Range("F" & 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
                       
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

The code should save all the new workbooks to the same folder as the main workbook.

I hope that this helps,

Cheerio,
vcoolio.

 

[pcloukas]

Hello PcLoukas,

See if this helps (untested):-

Option Explicit
Sub TestWbks()

        Dim i As Long, mypath As String, ar As Variant

Application.ScreenUpdating = False
Application.DisplayAlerts = False

        mypath = ThisWorkbook.Path & "\"
        ar = sh.Range("F2", sh.Range("F" & 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
                      
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

The code should save all the new workbooks to the same folder as the main workbook.

I hope that this helps,

Cheerio,
vcoolio.

Hello my friend and thank you for the reply, it stops here

 

[vcoolio]

Hello PcLoukas,

Perhaps I should have tested it!
Apologies! I've left out the sheet variable, sh, in the declared variables part. Hence, after ar As Variant, place sh As Worksheet. Make sure that there is a comma between the two variable declarations as follows:

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

Then set a value to the variable:
Set sh = ThisWorkbook.Sheets("Sheet1")
then place this directly after:
mypath = ThisWorkbook.Path & "\"

You can change "Sheet1" to the relevant sheet name from your main workbook.

The variable should now be defined within the code.

Cheerio,
vcoolio.

 

[pcloukas]

Hello PcLoukas,

Perhaps I should have tested it!
Apologies! I've left out the sheet variable, sh, in the declared variables part. Hence, after ar As Variant, place sh As Worksheet. Make sure that there is a comma between the two variable declarations as follows:

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

Then set a value to the variable:
Set sh = ThisWorkbook.Sheets("Sheet1")
then place this directly after:
mypath = ThisWorkbook.Path & "\"

You can change "Sheet1" to the relevant sheet name from your main workbook.

The variable should now be defined within the code.

Cheerio,
vcoolio.

like this?

Option Explicit
Sub TestWbks()

Dim i As Long, mypath As String, ar As Variant sh As Worksheet
Set sh = ThisWorkbook.Sheets("Sheet1")
mypath = ThisWorkbook.Path & "\"

Application.ScreenUpdating = False
Application.DisplayAlerts = False

mypath = ThisWorkbook.Path & "\"
ar = sh.Range("F2", sh.Range("F" & 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

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

 

[vcoolio]

You've left out the comma after Variant
So it should look like this:-

Option Explicit
Sub TestWbks()

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

Application.ScreenUpdating = False
Application.DisplayAlerts = False

        mypath = ThisWorkbook.Path & "\"
        Set sh = ThisWorkbook.Sheets("Sheet1")
        ar = sh.Range("F2", sh.Range("F" & 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
                       
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Cheerio,
vcoolio.

 

[pcloukas]

You've left out the comma after Variant
So it should look like this:-

Option Explicit
Sub TestWbks()

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

Application.ScreenUpdating = False
Application.DisplayAlerts = False

        mypath = ThisWorkbook.Path & "\"
        Set sh = ThisWorkbook.Sheets("Sheet1")
        ar = sh.Range("F2", sh.Range("F" & 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
                      
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Cheerio,
vcoolio.

Yes it seems to work but i cant find the files, their are not in the foldes of the main file

 

[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.

 

[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.

 

[vcoolio]

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

Cheerio,
vcoolio.