VBA to save to a folder searching for the first 5 digits of the folder name.

[Bagsy]

Hi
I wonder if anybody can help with this.
I have some code which will look at a cell value on my sheet (Which is a five-digit number), search in a directory open that folder and then open a subfolder within that folder & save the file.
This works just great if the parent folder & cell value are identical, but these parent folders will start with the 5 digit number then a space followed by some descriptive text.
Is there any way of searching just for the first 5 digits of a folder name?
Any help is always appreciated

Sub Save() 'Sub Save()' this is the save code so it will save to the correct TNumber folder
 Dim CurrentSheet As Worksheet
 Dim WB As Workbook
 Set CurrentSheet = ActiveSheet
 A = Cells(4, 3).Value 'row & column T number
   'Application.DisplayAlerts = False

Set WB = ActiveWorkbook

   '     Changing drive letter
      ChDrive "W:\"
'     Changing directory
On Error GoTo InvalidDirectory
      ChDir "W:\1WIS LIVE\" & A & "\11. Router & Inspection Report"
'     Prompt for new file location
     mySaveFile = Application.GetSaveAsFilename(Range("I4").Text & ".xlsm", "Microsoft Excel Workbook (*.xlsm), *.xlsm")
      If mySaveFile = False Then Exit Sub
'     Save
      ActiveWorkbook.SaveAs Filename:=mySaveFile, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
     ActiveWorkbook.Save

     CurrentSheet.Select
   Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Exit Sub



InvalidDirectory:
       ChDir "W:\1WIS LIVE"
'     Prompt for new file location
     mySaveFile = Application.GetSaveAsFilename(Range("I4").Text & ".xlsm", "Microsoft Excel Workbook (*.xlsm), *.xlsm")
      If mySaveFile = False Then Exit Sub

  '     Save
    ActiveWorkbook.SaveAs Filename:=mySaveFile, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
     ActiveWorkbook.Save
     CurrentSheet.Select
   Application.ScreenUpdating = True
    'Application.DisplayAlerts = True


End Sub

 

[NdNoviceHlp]

Not real clear on your needs but U can trial this...

Dim FSO As Object, Fl As Object
Set FSO = CreateObject("scripting.filesystemobject")
Set FlDr = FSO.GetFolder("W:\1WIS LIVE\" & A & "\11. Router & Inspection Report")
For Each Fl In FlDr.Files
If Left(ActiveSheet.Range("I4").Text, 5) = Left(Fl.Name, 5) Then
'something
End if
Next Fl

HTH. Dave

 

[Bagsy]

Thanks NDNoviceHip
Thanks for your suggestion, don’t think that is quite what I need

Apologies for not being clearer, what I am trying to achieve is on this line
Set FlDr = FSO.GetFolder("W:\1WIS LIVE\" & A & "\11. Router & Inspection Report")
It sets the file path to save the file where A is the cell “C4” on my sheet with 5-digit number.

For example, if this number on my sheet is 12345 and I have a folder in W:\1WIS LIVE\ called 12345, my code will open that particular folder and the sub folder within that called 11. Router & Inspection Report and save my excel file in that folder.

The problem is these folder names are not just a 5-digit number for example they have a description after the number, for example “12345 Description of tool”, but they all start with a unique 5-digit number.

What I need to be able to do is when it looks for the folder in file path W:\1WIS LIVE\ it disregards the description and looks at just the number, so in this example my number in cell “C4” is 12345 and I need to open a folder called “12345 Description of tool”, then the sub folder within that.
Is that possible to do?

Hope that is a better explanation
Many thanks for helping

 

[NdNoviceHlp]

Maybe this will work? Dave

Sub test()
Dim FSO As Object, Fl As Object, FlDr As Object
Dim Fl2 As Object, FlDr2 As Object, mySaveFile As String
Set FSO = CreateObject("scripting.filesystemobject")
Set FlDr = FSO.GetFolder("W:\1WIS LIVE")
'loop folders in W:\1WIS LIVE
For Each Fl In FlDr.Files
'match 1st 5 letters with folder name
If Left(ActiveSheet.Range("C4"), 5) = Left(Fl.Name, 5) Then
'set folder to found folder
Set FlDr2 = FSO.GetFolder("W:\1WIS LIVE\" & Fl.Name)
'loop folder to find if 11. Router & Inspection Report exists
For Each Fl2 In FlDr2.Files
If Fl2.Name = "11. Router & Inspection Report" Then
'create new file name
mySaveFile = "W:\1WIS LIVE\" & Fl.Name & "\" & Fl2.Name & "\" & CStr(ActiveSheet.Range("I4")) & ".xlsm"
ActiveWorkbook.SaveAs Filename:=mySaveFile, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Exit Sub
End If
Next Fl2
End If
Next Fl
Set Fl2 = Nothing
Set Fl = Nothing
Set FlDr = Nothing
Set FSO = Nothing
End Sub

 

[Bagsy]

Thanks Dave

I will give that a go, appreciate you helping me

 

[Bagsy]

OK Dave

Apologies but I cannot seem to get this to work
I have 46733 in Cell (“C4”) on the active sheet.
In “W:\1WIS LIVE” there is a folder named “46733 HEL 24 X 356894 X6 475”.

I ran the code but it did not find the folder

 

[NdNoviceHlp]

I set up a trial and this seems to work. Dave

Sub test()
Dim FSO As Object, Fl As Object, FlDr As Object
Dim Fl2 As Object, FlDr2 As Object, mySaveFile As String
Set FSO = CreateObject("scripting.filesystemobject")
Set FlDr = FSO.GetFolder("W:\1WIS LIVE")
For Each Fl In FlDr.subfolders
'match 1st 5 letters with folder name
If Left(ActiveSheet.Range("C4"), 5) = Left(Fl.Name, 5) Then
'set folder to found folder
Set FlDr2 = FSO.GetFolder("W:\1WIS LIVE\" & Fl.Name)
'loop folder to find if 11. Router & Inspection Report exists
For Each Fl2 In FlDr2.subfolders 'Files
If Fl2.Name = "11. Router & Inspection Report" Then
'create new file name
mySaveFile = "W:\1WIS LIVE\" & Fl.Name & "\" & Fl2.Name & "\" & CStr(ActiveSheet.Range("I4")) & ".xlsm"
ActiveWorkbook.SaveAs Filename:=mySaveFile, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Exit Sub
End If
Next Fl2
End If
Next Fl
Set Fl2 = Nothing
Set Fl = Nothing
Set FlDr = Nothing
Set FSO = Nothing
End Sub

 

[Bagsy]

Very much appreciated, I will have another go

 

[Bagsy]

Dave
That is so cool, works brilliantly, thank you so much. Nice piece of code

 

[NdNoviceHlp]

You are welcome. Thanks for posting your outcome. Dave