Need to save workbooks in today's date folder

[sg2209]

Good Morning,

Everyone is doing well !!

Though I am still in the learning phase and in past years learned so much from Forums and Youtube videos.

Need help with the below code where I have successfully saved the files in a folder by giving them a location and the location we need to put in the reference sheet.

I was also trying to write something that creates the current date folder first and then saves all the files in it but not sure how I make it hence I removed that part.

Option Explicit

Sub Seperate_Data_in_workbooks()

Application.ScreenUpdating = False


Dim data_sh As Worksheet
Set data_sh = ThisWorkbook.Sheets("Data")

Dim Refrence_Sh As Worksheet
Set Refrence_Sh = ThisWorkbook.Sheets("Refrences")

Dim nwb As Workbook
Dim nsh As Worksheet

''''' Get unique supervisors

Refrence_Sh.Range("A:A").Clear
data_sh.AutoFilterMode = False
data_sh.Range("BH:BH").Copy Refrence_Sh.Range("A1")

Refrence_Sh.Range("A:A").RemoveDuplicates 1, xlYes

Dim i As Integer

For i = 2 To Application.CountA(Refrence_Sh.Range("A:A"))

data_sh.UsedRange.AutoFilter 60, Refrence_Sh.Range("A" & i).Value


Set nwb = Workbooks.Add
Set nsh = nwb.Sheets(1)

data_sh.UsedRange.SpecialCells(xlCellTypeVisible).Copy nsh.Range("A1")
nsh.UsedRange.EntireColumn.ColumnWidth = 15

nwb.SaveAs Refrence_Sh.Range("H1").Value & "/" & Refrence_Sh.Range("A" & i).Value & ".xlsx"
nwb.Close False
data_sh.AutoFilterMode = False
Next i

Refrence_Sh.Range("A:A").Clear

MsgBox "Done"


End Sub

please help me how do I want all the files should always save in the current date folder?

also attached the same tool file the code in it is working fine I just want to know if we can save the files in the current folder and if the current date folder exits it shows the warning

 

[sg2209]

How do I attach the sample file please guide me.

 

[Logit]

This forum doesn't provide for attaching workbooks. You will need to use a 'cloud website' such as DROPBOX.COM then provide
the download link in your post.

 

[sg2209]

I am still trying to get my results however getting failed every time any luck please?

Should i provide the image of Code

 

[Logit]

You can post your code here ... absolutely. Having the actual workbook is better.

 

[sg2209]

Thank You so much I did resolve it myself.
Appreciate your time and efforts

 

[Fluff]

Good to hear you got the solution.
If you would like to post the solution then it is perfectly fine to mark your post as the solution to help future readers. Otherwise, please do not mark a post that doesn't contain a solution.

 

[sg2209]

here is the code i am using it

Sub Split_Data_in_workbooks()
    Dim sPath As String
    Dim sFileName As String
    Dim TodayDate As String

    Application.DisplayAlerts = False
    TodayDate = Format(Date, "dd-mm-yyyy")
    sPath = "\\corpfiler57\20007001_N01_NSL\Imp Data\Titanium Reports allocation\Auto Allocation Folder\" & TodayDate
    sFileName = "Group Performance Report" & " " & TodayDate & ".xls"
   
    On Error GoTo myerror
    If Dir(sPath, vbDirectory) = vbNullString Then MkDir sPath
myerror:
    Application.DisplayAlerts = True
    If Err > 0 Then MsgBox (Error(Err)), 16, "Error"
   
    ' Columns Arrangement
   
    Dim search As Range
Dim cnt As Integer
Dim colOrdr As Variant
Dim indx As Integer

colOrdr = Array("Allocated", "wrkgtrp_shrt_nm", "client_code", "creditor_reference_number", "consumer_name", "Regarding", "date_assigned2") 'define column order with header names here

cnt = 1


For indx = LBound(colOrdr) To UBound(colOrdr)
    Set search = Rows("1:1").Find(colOrdr(indx), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
    If Not search Is Nothing Then
        If search.Column <> cnt Then
            search.EntireColumn.Cut
            Columns(cnt).Insert Shift:=xlToRight
            Application.CutCopyMode = False
        End If
    cnt = cnt + 1
    End If
Next indx
   
   
   
Application.ScreenUpdating = False


Dim data_sh As Worksheet
Set data_sh = ThisWorkbook.Sheets("Data")

Dim Refrence_Sh As Worksheet
Set Refrence_Sh = ThisWorkbook.Sheets("Refrences")

Dim nwb As Workbook
Dim nsh As Worksheet

''''' Get unique supervisors

Refrence_Sh.Range("A:A").Clear
data_sh.AutoFilterMode = False
data_sh.Range("A:A").Copy Refrence_Sh.Range("A1")

Refrence_Sh.Range("A:A").RemoveDuplicates 1, xlYes

Dim i As Integer

For i = 2 To Application.CountA(Refrence_Sh.Range("A:A"))
   
    data_sh.UsedRange.AutoFilter 1, Refrence_Sh.Range("A" & i).Value
   
   
    Set nwb = Workbooks.Add
    Set nsh = nwb.Sheets(1)
   
    data_sh.UsedRange.SpecialCells(xlCellTypeVisible).Copy nsh.Range("A1")
    nsh.UsedRange.EntireColumn.ColumnWidth = 15
   
'    nwb.SaveAs Refrence_Sh.Range("H1").Value & "/" & Refrence_Sh.Range("A" & i).Value & ".xlsx"
        nwb.SaveAs Filename:=sPath & "\" & Refrence_Sh.Range("A" & i).Value & ".xlsx"
    nwb.Close False
    data_sh.AutoFilterMode = False
Next i

Refrence_Sh.Range("A:A").Clear

MsgBox "Done"


End Sub