I'm trying to save excel file into a specific path.
So basically, when I click the button, I'm creating a folder, and want to save the file inside that folder.
The created folder has the current month as name. I'm trying to save into that current month folder.
'Create folder as Month Name. Save filename as date inside "month".
Dim sDate As String = DateTime.Now.ToString("yyyy-MM-dd") & "_" & DateTime.Now.ToString("HH-mm-ss")
Dim sMonth As String = DateTime.Now.ToString("MMMM")
Dim sFolder = Application.StartupPath & "\Resources\Excel\"
My.Computer.FileSystem.CreateDirectory(sFolder & Format(sMonth))
Dim sfinal = Path.Combine(sFolder, sMonth)
xlSh.SaveAs(sfinal & Format(sDate) & ".xlsx")
xlApp.Workbooks.Close()
xlApp.Quit()
As it is, this code doesn't give me any errors. But instead of creating a folder named "March" <-current month and saving inside it, it saves the file in \Excel\ and it also creates folder in the same place.
you could use the following function (similar to .NET System.IO.Path.Combine)
Function PathCombine(path1 As String, path2 As String)
Dim combined As String
combined = path1
If Right$(path1, 1) <> Application.PathSeparator Then
combined = combined & Application.PathSeparator
End If
combined = combined & path2
PathCombine = combined
End Function
Hope this helps!
After long hours of excruciating pain, I've finally did it!
Apparently I was missing an "\"
Since "sMonth" became dynamic name, which later I wanted to use as path, and save files in that folder. I needed to simply put that "\" after sMonth, to tell it to save inside it.
Before I realize this... I've broken down, simplified the code as much as I could so I can logically connect the pieces. What I ended up with, is something slightly different. Now the SaveAS properly saves the file inside the new folder.
Dim sDate As String
sDate = DateTime.Now.ToString("yyyy-MM-dd") & "_" & DateTime.Now.ToString("HH-mm-ss")
Dim sMonth As String
sMonth = DateTime.Now.ToString("MMMM")
Dim sFileName As String
sFileName = sDate + ".xlsx"
Dim sFolder As String
sFolder = Application.StartupPath & "\Resources\Excel\"
Dim sfinal As String
sfinal = (sFolder & sMonth & "\") '<- this thingie here o.O
My.Computer.FileSystem.CreateDirectory(sFolder & Format(sMonth))
xlSh.SaveAs(sfinal & Format(sFileName))
xlApp.Workbooks.Close()
xlApp.Quit()
Thanks for the help.
You don't appear to actually be setting the save path to the created directory. Instead, I believe you're appending the month to the beginning of the file name in the xlSh.SaveAs(sFinal & Format(sDate) & ".xlsx"). Basically (though I'm not sure of the specific command) you need to navigate to the folder you created after you create it. Probably something to the format of
My.Computer.FileSystem.ChangeDirectory(sFolder & Format(sMonth))
though I don't know that that specific command actually exists as I wrote it.
To those who have been wondering wtf I was doing with all this, here is the full sub. And if anyone needs something similar. Thanks for the support. Problem has been resolved.
Private Sub Button_Click(sender As Object, e As EventArgs) Handles Button.Click
Dim xlApp As Excel.Application
Dim xlSh As Excel.Worksheet
xlApp = New Excel.Application
xlApp.Workbooks.Add()
xlSh = xlApp.Workbooks(1).Worksheets(1)
'Items from listbox1 to be exported into excel, second row, second column.
Dim row As Integer = 2
Dim col As Integer = 2
For i As Integer = 0 To ListBox1.Items.Count - 1
xlSh.Cells(row, col) = ListBox1.Items(i)
row = row + 1
Next
row += 1
col = 1
'Items from listbox2 to be exported into excel, second row, third column.
Dim row2 As Integer = 2
Dim col2 As Integer = 3
For i As Integer = 0 To ListBox2.Items.Count - 1
xlSh.Cells(row2, col2) = ListBox2.Items(i)
row2 = row2 + 1
Next
row2 += 1
col2 = 1
'Create folder as Month Name. Save filename as date inside that folder.
'Make filename be yyyy-MM-DD_HH-mm-ss
Dim sDate As String
sDate = DateTime.Now.ToString("yyyy-MM-dd") & "_" & DateTime.Now.ToString("HH-mm-ss")
'This will be used as name for the new folder.
Dim sMonth As String
sMonth = DateTime.Now.ToString("MMMM")
'Filename + extension.
Dim sFileName As String
sFileName = sDate + ".xlsx"
'This is the path.
Dim sFolder As String
sFolder = Application.StartupPath & "\Resources\Excel\"
'This is the path combined with sMonth to make the final path.
Dim sfinal As String
sfinal = (sFolder & sMonth & "\")
'Check if folder with the name sMonth already exists.
If Dir(sFolder, vbDirectory) = sMonth Then
'If it exist, then simply save the file inside the folder.
xlSh.SaveAs(sfinal & Format(sFileName))
Else
'If it doesn't exist:
'This is the creation of sMonth folder, inside "\excel\.
My.Computer.FileSystem.CreateDirectory(sFolder & Format(sMonth))
'This saves the excel file at path sfinal, with filename of sFileName
xlSh.SaveAs(sfinal & Format(sFileName))
End If
'Close everything.
xlApp.Workbooks.Close()
xlApp.Quit()
End Sub
I find this method to be much easier.
Create a FileSystemObject and use BuildPath Method, like so:
Set fs = CreateObject("Scripting.FileSystemObject")
skPath = fs.BuildPath(ActiveDocument.Path, "Survival Story of Sword King")
Attention: ActiveDocument.Path is current directory in Word and does not work in excel or other. for excel it would be ActiveWorkbook.Path
My point is some methods or namespace are application specific.
Related
Using 2010 Excel VBA - I need to use look up the image/pdf with the Branch Code as a part of its name at "C:\ECB Test\ECB IR COPY" and paste it at "C:\ECB Test\" RO if it exists. If it doesn't, the program needs to highlight the Branch Code.
(File Name Examples: 28-Kochi-ecb-sdwan completed.pdf, 23 eCB Kozhikode completed.pdf/0036.jpeg)
Having done this manually twice for two other excel sheets (4k+ cells), I decided to Frankenstein a module together and, well, it does not work and I have no idea why.
Sub Sort()
Const SRC_PATH As String = "C:\ECB Test\ECB IR COPY"
Const DEST_PATH As String = "C:\ECB Test"
Dim Row_Number As Integer
Dim fso As Object
Set fso = VBA.CreateObject("Scripting.FileSystemObject")
Dim Folder_Name As String
Dim Branch_Code As String
Dim Final_Path As Variant
Dim File As String
For Row_Number = 3 To 2465
Branch_Code = Worksheets("WAN RFP").Cells(Row_Number, 2)
Folder_Name = Worksheets("WAN RFP").Cells(Row_Number, 5)
On Error Resume Next
File = Dir(SRC_PATH & "\*" & Branch_Code & "*")
Final_Path = Dir(DEST_PATH & "\" & Folder_Name & "\")
If (Len(File) > 0) Then
Call fso.CopyFile(File, Final_Path)
Else
Cells(Row_Number, 2).Interior.ColorIndex = 6
End If
On Error GoTo 0
DoEvents
Next Row_Number
End Sub
I think its unable to use the Branch Code variable as a wildcard, though I might as well have done something silly somewhere in the code. Can someone please help me out?
The problem is you are using the destination path instead of the source path:
File = Dir(DEST_PATH & "*" & Branch_Code & "*.*")
Change it to
File = Dir(SRC_PATH & "*" & Branch_Code & "*.*")
I need to connect to a network drive and create a folder. I dont know the IP of the drive. Also I dont want to use the drive letter as this VBA will be used by many people on their PC.
I tried this :
Public Function create_folder()
Dim NetworkObject As Object
Dim FSO As Object
Dim Directory As Object
Dim Filename As Object
Dim ServerShare As String
ServerShare = "\\SSSXCXC\FOL_SAS\ASD123\"
Set NetworkObject = CreateObject("WScript.Network")
Set FSO = CreateObject("Scripting.FileSystemObject")
NetworkObject.MapNetworkDrive "", ServerShare, False
Set Directory = FSO.CreateFolder(ServerShare & "\AAA")
End Function
But I am getting path error.
I think you don't need to map the network drive to create a folder. If you have write access, the folder should be created.
Const SERVER_PATH As String = "\\SSSXCXC\FOL_SAS\ASD123\"
Dim folderPath As String
folderPath = SERVER_PATH & "AAA"
With CreateObject("Scripting.FileSystemObject")
If Not .FolderExists(folderPath) Then .CreateFolder folderPath
End With
Function GetNetworkPath(ByVal DriveName As String) As String
Dim objNtWork As Object
Dim objDrives As Object
Dim lngLoop As Long
Set objNtWork = CreateObject("WScript.Network")
Set objDrives = objNtWork.enumnetworkdrives
For lngLoop = 0 To objDrives.Count - 1 Step 2
If UCase(objDrives.Item(lngLoop)) = UCase(DriveName) Then
GetNetworkPath = objDrives.Item(lngLoop + 1)
Exit For
End If
Next
End Function
I have a similar problem which I'll explain, and a working solution at the bottom (which can write to the network but not copy).
I would like to copy a folder on the network and rename it.
It's a folder with a nest of sub-folders we use as a template.
It looks like it should work from the Locals window, but the folder doesn't get created.
I assume it's a network rights problem
Sub CreateMajorResponseFile()
'creates a response folder with the app number as folder name
'declare road name as a variable
Dim Road As String
Dim AppNo As String
Dim Prefix As String
Dim FolderPath As String
Dim tbl As ListObject
Dim LastRow As Long
'enable code to use Scripting.FileSytemObject so it's easy to copy and rename a folder pt1
Dim FSO As Object
'pt2 of enable code to use Scripting.FileSytemObject so it's easy to copy and rename a folder
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim SourceFolder As String
Dim DestinationFolder As String
'set the folder you want to copy
SourceFolder = "S:my source folder"
'set the file path for the folder you want to copy to
DestinationFolder = "S:\my destination folder" & Road
'set the road variable to be 4 rows right of selected cell
Road = ActiveCell.Offset(0, 4).value
'set the AppNo the selected cell
AppNo = ActiveCell.value
AppNo = Left(AppNo, 6) & "-" & Right(AppNo, 5)
Prefix = Application.InputBox("Enter N followed by EITHER property number OR short name", "Give it a prefix", "N")
''create folder with file path to the road name folder
'MkDir "S:\my network path" & "\" & Road & "\" & Prefix & " " & AppNo & Suffix
FSO.CopyFolder Source:=SourceFolder, Destination:=DestinationFolder & "\" & Prefix & " " & AppNo
End Sub
But I have another piece of code that can create a new folder on the network without using file system objects. This is the code
Sub CreateResponseFile()
'creates a response folder with the app number as folder name
'declare road name as a variable
Dim Road As String
Dim AppNo As String
Dim Prefix As String
Dim Suffix As String
Dim FolderPath As String
'set the road variable to be 4 rows right of selected cell
Road = ActiveCell.Offset(0, 4).value
'set the AppNo the selected cell
AppNo = ActiveCell.value
AppNo = Left(AppNo, 6) & "-" & Right(AppNo, 5)
Prefix = Application.InputBox("Enter N followed by EITHER property number OR short name", "Give it a prefix", "N")
Suffix = Application.InputBox("Enter a space followed by e.g. C16 cycl parking or CEMP etc, if full app leave blank", "Give it a suffix", " C99EVCP")
'create folder with file path to the road name folder
MkDir "S:\my network path" & "\" & Road & "\" & Prefix & " " & AppNo & Suffix
End Sub
so it seems MkDir can work over a network where FSO copy cannot
I want to create folders with Excel, in a way that every time a make a new entry in the selected column, a new folder is created.
I already searched and found some codes to VBA that creates the folders. But I have to select the cells and then run the macro everytime. Is there any way that I can do that automatically?
Thank you in advance,
Leo
Below is the code for creating new folders (Sub directories)
Sub CreateFolder()
Dim caminho As String
Dim folder As Object, FolderName
For i = 1 To 500
Set folder = CreateObject("Scripting.FileSystemObject") FolderName = ActiveWorkbook.Path & "\" & Range("A" & i).Value
If Not folder.FolderExists(FolderName) Then
folder.CreateFolder (FolderName)
End If
directory = ThisWorkbook.Path
Next i
End Sub
Yes, we can help you. Just need some pertinent info. Does the column need to be selected? Or can you work with a hard coded column? Say a column like Column D... We can put a Worksheet_Change macro on your worksheet module so that whenever a value in a certain column is changed - it will automatically check to see if that folder exists and if not then create it.
Here is an example that will create folders for any new or changed cells in column D:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim caminho As String
Dim folder As Object, FolderName
If Target.Column = 1 And Target.Value <> "" Then ' If Changed Cell is in Column A
' This code changes unacceptable file name characters with an underscore
Filename = Target.Value
MyArray = Array("<", ">", "|", "/", "*", "\", "?", """")
For X = LBound(MyArray) To UBound(MyArray)
Filename = Replace(Filename, MyArray(X), "_", 1)
Next X
' This code creates the folder if it doesn't already exist
Set folder = CreateObject("Scripting.FileSystemObject")
FolderName = ActiveWorkbook.Path & "\" & Filename
If Not folder.FolderExists(FolderName) Then
folder.CreateFolder (FolderName)
End If
End If
End Sub
I created a macro button to open my daily files from a excel production sheet where I have all the my macro button for specific files.
The format for all my files are conventionally the same:
Businese Unit Name: YMCA
Year:2012
Month: April
Week: Week 2
Day: 12
File Name: YMC Template 041212.xlsm
I am having issue with the last excel file name extension.
how do I add the MyDaily Template and MyDateProd along with the .xlsm.
I have this -J:.....\& myDailyTemplate & myDateProd.xlsm") see below for entire file path names.
Sub Open_DailyProd()
Dim myFolderYear As String
Dim myFolderMonth As String
Dim myFolderWeek As String
Dim myFolderDaily As String
Dim myDateProd As String
Dim myBusinessUnit As String
Dim myDailyTemplate As String
myBusinessUnit = Sheet1.Cells(32, 2)
myFolderYear = Sheet1.Cells(11, 2)
myFolderMonth = Sheet1.Cells(12, 2)
myFolderWeek = Sheet1.Cells(13, 2)
myFolderDaily = Sheet1.Cells(14, 2)
myDateProd = Sheet1.Cells(15, 2)
myDailyTemplate = Sheet1.Cells(6, 5)
Application.Workbooks.Open ("J:\IAS\3CMC05HA01\IAC Clients\myBusinessUnit\myFolderYear\myFolderMonth\myFolderWeek\myFolderDaily\& myDailyTemplate & myDateProd.xlsm")
End Sub
Excel is looking for a file called:
"J:\IAS\3CMC05HA01\IAC Clients\myBusinessUnit\myFolderYear\myFolderMonth\myFolderWeek\myFolderDaily\& myDailyTemplate & myDateProd.xlsm"
since that is what is included in the quotes, but from your code, you appear to have a number of variables that are part of this string, you need to take them out of the quotes and concatenate them together. Try something like this:
"J:\IAS\3CMC05HA01\IAC Clients\" & myBusinessUnit & "\" & myFolderYear _
& "\" & myFolderMonth & "\" & myFolderWeek & "\" & myFolderDaily & _
"\" & myDailyTemplate & myDateProd & ".xlsm"
I added the continuation _ to make it more readable onthe screen here, but it is not necessary, you can put everything on one line together if you prefer.
Unless you need all of the myBusinessUnit, myFolderYear, etc variables elsewhere, I would think about doing it in some sort of array and then doing a Join function to concatenate everything. I, personally, find this easier to maintain going forward and easier to see the hierarchy in the folder structure rather than looking at a very long string and trying to find what part of the path is wrong.
Sub Open_DailyProd()
Dim pathParts(1 To 10) As String
Dim path As String
pathParts(1) = "J:"
pathParts(2) = "IAS"
pathParts(3) = "3CMC05HA01"
pathParts(4) = "IAC Clients"
pathParts(5) = Sheet1.Cells(32, 2)
pathParts(6) = Sheet1.Cells(11, 2)
pathParts(7) = Sheet1.Cells(12, 2)
pathParts(8) = Sheet1.Cells(13, 2)
pathParts(9) = Sheet1.Cells(14, 2)
pathParts(10) = Sheet1.Cells(6, 5) & Sheet1.Cells(15, 2) & ".xlsm"
path = Join(pathParts, "\")
Application.Workbooks.Open (path)
End Sub
I'd like to save a file in the following example folder:
C:\MainFolder\Subfolder1\Subfolder2\Subfolder3_A_abc_123
There are other subfolders in the folder where I'd like the file be saved, like:
Subfolder_B_xyz_456
Subfolder_C_rst_789
etc
The thing is that I want to find a folder on the the path all the way up to: "Subfolder3_", the "A" will be fetched from a range in a sheet and the "_abc_123", I do not want to match.
Does anyone have a clever FSO example or other creative sollution? I'm new to programming so any suggestion is appreciated.
Thanks on advance.
PythonStyle
Updated question to ho1:
This is the code:
Sub Create_WorkB_Input()
Dim wbBook1 As Workbook
Dim wbBook2 As Workbook
Dim shTemp1 As Worksheet
Dim shTemp2 As Worksheet
Dim shTemp_admin As Worksheet
Dim shTSSR_inp1 As Worksheet
Dim shTSSR_inp2 As Worksheet
Dim strVersion As String
Dim strPrep As String
Dim Datecr As Date
Dim strComment As String
Dim intBatch As Integer
Dim strSiteID As String
Dim strClusterID As String
Dim strPath As String
Dim fso As New FileSystemObject
Dim flds As Folders
Dim f As Folder
Set wbBook1 = Workbooks("Name_Input_TEMPLATE_v4.0.xls")
Set wbBook2 = Workbooks("Name_Input_To_xxx.xlsm")
Set shTemp1 = Workbooks("Name_Input_TEMPLATE_v4.0.xls").Sheets("TSSR_Input_sh1")
Set shTemp2 = Workbooks("Name_Input_TEMPLATE_v4.0.xls").Sheets("TSSR_Input_sh2")
Set shTSSR_inp1 = Workbooks("Name_Input_To_xxx.xlsm").Sheets("xxx")
Set shTSSR_inp2 = Workbooks("Name_Input_To_xxx.xlsm").Sheets("yyy")
Set shTemp_admin = Workbooks("Name_Input_TEMPLATE_v4.0.xls").Sheets("www")
shTSSR_inp1.UsedRange.Copy
shTemp1.Paste
shTSSR_inp2.UsedRange.Copy
shTemp2.Paste
intBatch = shTemp1.Range("AQ2").Value
strSiteID = shTemp1.Range("A2").Value
strClusterID = shTemp1.Range("B2").Value
strComment = InputBox(Prompt:="Insert comments.", Title:="INSERT COMMENTS", Default:="New site - batch " & intBatch & " ref email fr Me dato")
With shTemp_admin
.Range("A18").FormulaR1C1 = "4.0"
.Range("B18").Value = "John Doe"
.Range("C18").Value = Date
.Range("D18").Value = strComment
End With
strPath = "D:\Path_to_folder\folder1\folder2\folder3\folder4"
Set flds = fso.GetFolder(strPath & "\Folder5_Input_Batch_" & intBatch & "*")
For Each f In flds
If f.Name Like strPath Then
wbBook1.SaveAs Filename:="" + strPath + "\" + "TSSR_Input_" + strClusterID + "_" + strSiteID + "_v4.0.xls", _
FileFormat:=xlNormal, _
Password:="", _
WriteResPassword:="", _
ReadOnlyRecommended:=False, _
CreateBackup:=False
End If
Next
End Sub
I am getting error at this line :
Set flds = fso.GetFolder(strPath & "\Folder5_Input_Batch_" & intBatch & "*")
Could you please have a look at it?
The names of folders and workbooks are changed so they might not make any sense. Only the folder part is important.
Thanks in advance.
Rgds
P
You could just loop through all the subdirectories and for each directory you compare it with the path you want to find. Something like this pseudo code should work:
For each dir in SubDirectories
Dim lookingFor as String
lookingFor = "Subfolder3_" & yourVariable & "*"
If dir.Name Like lookingFor Then ' Note the use of the Like operator here so that it sees the * as a wildcard
' This is the right one
End If
Next
An other, similar, option would be to use regular expressions which are more powerful than Like, but I don't think you'd need that. However, just in case, you can find information about it here: How to Use Regular Expressions in Visual Basic
Nothing wrong with the posted solution. I just thought I would also post another alternative using the Dir() function, which should be a little faster - especially if you have a lot of subdirectories to search.
i.e.
Dim strFoundDir as String
strFoundDir=dir("C:\MainFolder\Subfolder1\Subfolder2\SubFolder3*" & SomeVariable & "*", vbDirectory)
if lenb(strFoundDir)>0 then
'Do the rest of your code
end if