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

Bagsy

Active Member
Joined
Feb 26, 2005
Messages
377
Office Version
  1. 365
Platform
  1. Windows
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
VBA Code:
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
 

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
2,776
Not real clear on your needs but U can trial this...
Code:
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

Active Member
Joined
Feb 26, 2005
Messages
377
Office Version
  1. 365
Platform
  1. Windows
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

Well-known Member
Joined
Nov 9, 2002
Messages
2,776
Maybe this will work? Dave
Code:
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

Active Member
Joined
Feb 26, 2005
Messages
377
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Thanks Dave

I will give that a go, appreciate you helping me
 

Bagsy

Active Member
Joined
Feb 26, 2005
Messages
377
Office Version
  1. 365
Platform
  1. Windows
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

Well-known Member
Joined
Nov 9, 2002
Messages
2,776

ADVERTISEMENT

I set up a trial and this seems to work. Dave
Code:
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

Active Member
Joined
Feb 26, 2005
Messages
377
Office Version
  1. 365
Platform
  1. Windows
Very much appreciated, I will have another go
 

Bagsy

Active Member
Joined
Feb 26, 2005
Messages
377
Office Version
  1. 365
Platform
  1. Windows
Dave
That is so cool, works brilliantly, thank you so much. Nice piece of code
 

Watch MrExcel Video

Forum statistics

Threads
1,129,549
Messages
5,636,933
Members
416,953
Latest member
prakashkumar

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top