I have a worksheet with data but I need to add the time at which the Data was created. This time is the "Last Modified"-time of the file I got the data from.
I already got all the filenames as in "filename.txt" in the first column of the worksheet so each line of data can be referenced to its file. I have this function to pull the LastModified-Date from the filename:
Function FileLastModified(strFullFileName As String)
strFullFileName = "C:\...\filefolder\" + Range("A1").Value
Dim fs As Object, f As Object, s As String
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(strFullFileName)
s = UCase(strFullFileName) & vbCrLf
s = f.DateLastModified
FileLastModified = s
Set fs = Nothing: Set f = Nothing
End Function
Now I want the function to go through all the filenames in column A and put all the LastModified-Times in column D. So how do I edit this
strFullFileName = "C:\.....\" + Range("A1").Value
to automatically pull the filename from the A-Column?
Something like this?
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim i As Long
Dim n As Long
Dim filenames As Variant
Dim lastModifiedTimes As Variant
'How many filenames are there? (should tailor this to your exact situation)
n = Range("A:A").Find("*", Range("A1"), SearchDirection:=xlPrevious).Row
filenames = Range("A1").Resize(n, 1).Value 'load all fnames from sheet to array
ReDim lastModifiedTimes(1 To n, 1 To 1)
For i = 1 To n
lastModifiedTimes(i,1) = _
FSO.GetFile("C:\.....\" & filenames(i,1)).DateLastModified
Next i
'Slap times array onto sheet
Range("D1").Resize(n, 1).Value = lastModifiedTimes
Note that I got rid of your FileLastModified wrapper function since it's really only wrapping one thing, and it can be replaced by one single line of code.
Related
So, before I place my code, I'll explain what I am trying to do, because I can't test the script myself due to what it is supposed to do, effecting what it must do. I know this is a bit odd, but bear with me please.
Once every two weeks or so, we currently run batch files to update a specific tool on all the WS's in our organization.
Yes, we do have tool propagation software, but as this specific tool is extremely important, we don't trust it's distribution to any automated method which have proven in most cases to fail without us being able to understand the reason.
So, I wrote a few simple command batch files which run the installation command, and write the output to a text file which we then manually go through to find which ws's it was installed on, and which it wasn't.
The ws's on which it was not installed are the ws's we know we know due to the failure, that we have additional issues with and we then put all our effort into finding and fixing those issues.
As you can imagine, it's a time consuming effort, and I have decided I want to automate as much as possible of the manual check, in order to know quickly which ws's failed, and the fail code.
I start out with a list of ws names in excel.
For example,
K190ASSn1.domainname
m930eastgate.domainname
n190alka.domainname
n190amsv.domainname
n190amzi.domainname
N190ARME.domainname
N190AVMA.domainname
N190AVNT.domainname
n190chockstest.domainname
N190DLCR.domainname
N190DNBS.domainname
N190edsh.domainname
n190ehma2.domainname
N190EISH.domainname
I wrote my script to do the following:
Read all the ws names from column A into an array.
Loop through the array, and use the Shell function to call an external cmd file which then runs, and writes the result of the run into a TXT file located in a directory on the D drive called "Minstall".
I then read the names of all the files created in that directory into a new array.
I sort both arrays from A to Z (using a script I found online) to get everything in the same order for the next stage.
I then loop through the file names in the 2nd array, and read each file into a text field which I then parse to find the result of the script run.
That result is then written into a third array in the same logical position of the file name I read.
Finally, I re-write the file names back to the worksheet, overwriting what was there, and in the adjacent column, I write the run result from the relevant cell position in the third array.
I will then end up with a file that contains all the data in one visible point (I hope).
At a later stage, I will add a script that will email the relevant team with a list of the ws's they need to deal with (Those with any run result different from zero), and what they need to do. But that's not for the here and now.
Since if I run the code and it works (I hope) it would perform the update, and I do not yet want to do that, what I am really looking for, is additional eyes to go over my code, to see if what I wrote for each action as defined above is correct and will work, and if there is a way to perhaps write what I did, better.
In general, I went over each stage and everything "looks" good.
Anyone willing to assist here ?
Added by request of #CDP1802:
Examples of the two different results that can be found in the text files. One contains a result of zero, meaning that the script worked. The other contains a code of 1603, which is a generic "there's a problem captain but I don't know what it is" response from M$ msiexec.
The spaces between the lines of the text are what appear in the actual text file.
Example 1 (0 response)
PsExec v2.33 - Execute processes remotely
Copyright (C) 2001-2021 Mark Russinovich
Sysinternals - www.sysinternals.com
C:\Windows\system32>msiexec /i "\\server\Minstall\Installation.msi" /qn ACCEPTEULA=YES REPORTSERVER=server.domainname USESSL=TRUE REPORTSERVERPORT=443 IGNORESSLERRORS=TRUE InstallCertificates=yes /l*v C:\Windows\TEMP\install_log4258289.txt
Connecting to K190LPRTLV4.iaadom...
Starting PSEXESVC service on K190LPRTLV4.iaadom...
Copying authentication key to K190LPRTLV4.iaadom...
Connecting with PsExec service on K190LPRTLV4.iaadom...
Copying d:\Install425.bat to K190LPRTLV4.iaadom...
Starting d:\Install425.bat on K190LPRTLV4.iaadom...
Install425.bat exited on K190LPRTLV4.iaadom with error code 0.
Example 2 (1603 response)
PsExec v2.33 - Execute processes remotely
Copyright (C) 2001-2021 Mark Russinovich
Sysinternals - www.sysinternals.com
C:\Windows\system32>msiexec /i "\\server\Minstall\Installation.msi" /qn ACCEPTEULA=YES REPORTSERVER=server.domainname USESSL=TRUE REPORTSERVERPORT=443 IGNORESSLERRORS=TRUE InstallCertificates=yes /l*v C:\Windows\TEMP\install_log4258289.txt
Connecting to K190LPRTLV3.iaadom...
Starting PSEXESVC service on K190LPRTLV3.iaadom...
Copying authentication key to K190LPRTLV3.iaadom...
Connecting with PsExec service on K190LPRTLV3.iaadom...
Copying d:\Install425.bat to K190LPRTLV3.iaadom...
Starting d:\Install425.bat on K190LPRTLV3.iaadom...
Install425.bat exited on K190LPRTLV3.iaadom with error code 1603.
The updated code is as follows:
Option Explicit
Sub Check_Files()
Const Col_Names = "A"
Const Col_Result = "B"
Const Row_Text = 4 'first line of text and result
Dim wb As Workbook
Dim wsMain As Worksheet
Dim WSNames() As String 'Will hold all the ws names as an array read from column A
Dim WSResult() 'Will hold result for specific ws
Dim DirectoryListArray() As string
ReDim DirectoryListArray(3000) 'Set the directory listing array size to 3000 as a max count
Dim NumberArray() As Long
Dim lastrow As Long, FileCount As Long, NumberCount As Long, r As Long, i As Long, j As Long
Dim awsname as string, strDir As string, strPath As string
Dim item as variant
Dim ReadFile As String, text As String, textline As String, RetCode As Integer
Set wb = ActiveWorkbook
With wb
Set wsMain = .Sheets("Main")
End With
'Copy ws names into array for speed
With wsMain
lastrow = .Cells(.Rows.Count, Col_Names).End(xlUp).Row
If lastrow < Row_Text Then
MsgBox "No ws names found in column " & Col_Names, vbCritical
Exit Sub
End If
WSNames = .Cells(1, Col_Names).Resize(lastrow).Value2
ReDim WSResult(1 To lastrow)
End With
'Write how many names were read into array
Cells(1,3) = "Number of names read into array is " & lastrow
'loop through all ws names and run the batch file for each one
For r = Row_Text To UBound(WSNames)
awsname = WSNames(r, 1) 'Read in next ws name from array
Runcmd(awsname)
Next r
'Write how many batch files were run into worksheet
Cells(2,3) = "Number of batch files run is " & r
'count how many text files have been created
strDir = "D:\Minstall"
strPath = strDir & "\*.txt"
'Loop through all the files in the directory by using Dir$ function
MyFile = Dir$(strPath)
Do While MyFile <> ""
DirectoryListArray(FileCount) = MyFile
MyFile = Dir$
FileCount = FileCount + 1
Loop
'Reset the size of the array without losing its values by using Redim Preserve
Redim Preserve DirectoryListArray(FileCount - 1)
'Write how many text files were found
Cells(3,3) = "Number of txt files found is " & FileCount
''Debug.Print writes the results to the Immediate window (press Ctrl + G to view it)
'For FileCount = 0 To UBound(DirectoryListArray)
'Debug.Print DirectoryListArray(FileCount)
'Next FileCount
'Sort the arrays so that we have the same order in both arrays
'Since both arrays should in effect have the same amount of elements
'sorting names array from A to Z
For i = LBound(WSNames) To UBound(WSNames)
For j = i + 1 To UBound(WSNames)
If UCase(WSNames(i,1)) > UCase(WSNames(j,1)) Then
Temp = WSNames(j,1)
WSNames(j,1) = WSNames(i,1)
WSNames(i,1) = Temp
End If
Next j
Next i
'sorting file array from A to Z
For i = LBound(DirectoryListArray) To UBound(DirectoryListArray)
For j = i + 1 To UBound(DirectoryListArray)
If UCase(DirectoryListArray(i,1)) > UCase(DirectoryListArray(j,1)) Then
Temp = DirectoryListArray(j,1)
DirectoryListArray(j,1) = DirectoryListArray(i,1)
DirectoryListArray(i,1) = Temp
End If
Next j
Next i
NumberCount = 0
'Loop through files in directory based on what's in array
For i = LBound(DirectoryListArray) To UBound(DirectoryListArray)
ReadFile = "D:\Minstall" & "\" & DirectoryListArray(NumberCount)
ReadFile = Application.GetOpenFilename()
Open myFile For Input As #1
Do Until EOF(1)
Line Input #1, textline
text = text & textline
Loop
Close #1
RetCode = InStr(text, "with error code ")
NumFound = Mid(text, posLat + 16, 1)
If NumFound > 0 Then
NumFound = Mid(text, posLat + 16, 4)
'Write the number found into the number array
NumberArray(NumberCount) = NumFound
NumberCount = NumberCount + 1
Else
'Write the number found into the number array
NumberArray(NumberCount) = NumFound
NumberCount = NumberCount + 1
End If
Next i
'Write the ws name into the worksheet and write the number found to the cell to the right of the ws name in the worksheet
For i = LBound(WSNames) To UBound(WSNames)
Cells(j, Col_Names) = WSNames(i,1)
Cells(j, Col_Result) = NumberCount(i,1)
j = j + 1
Next i
End Sub
Sub Runcmd(awsname)
Dim PathToBatch as string
'Set the path and batch file with the ws name as a parameter for the batch to run
PathToBatch = "D:\min425.cmd" & " " & awsname
Call Shell(PathToBatch, vbNormalFocus)
End Sub
The main changes are using a FileSystemObject to read the text files, a Regular Expression to extract the error code, and a WScript.Shell object to run the batch file so macro waits for the script to complete. I have commented out the RunCmd line and replaced it with a RunTest that creates a text file so you can test it.
Option Explicit
Sub Check_Files()
Const DIR_OUT = "D:\Minstall"
Const COL_NAMES = "A"
Const COL_RESULTS = "B"
Const COL_TS = "C" ' timestamp
Const COL_ERR = "D" ' Shell errors
Const ROW_START = 4 'first line of text and result
Dim wb As Workbook, ws As Worksheet
Dim rng As Range, arNames, awsname As String
Dim result As String, txtfile As String
Dim i As Long, LastRow As Long, n As Long, r As Long, colour As Long
Dim t0 As Single: t0 = Timer
Set wb = ThisWorkbook
Set ws = wb.Sheets("Main")
With ws
' read names into array
LastRow = .Cells(.Rows.Count, COL_NAMES).End(xlUp).Row
n = LastRow - ROW_START + 1
If n < 1 Then
MsgBox "No records found on " & ws.Name, vbCritical
Exit Sub
Else
Set rng = .Cells(ROW_START, COL_NAMES).Resize(n)
arNames = rng.Value2
'Write how many names were read into array
.Cells(1, 3) = "Number of names read into array is " & n
End If
' clear results
With rng.Offset(, 1).Resize(, 3)
.Clear
.Interior.Pattern = xlNone
End With
' run commands with WsSCript
Dim WShell As Object
Set WShell = CreateObject("WScript.Shell")
For i = 1 To UBound(arNames)
awsname = arNames(i, 1)
r = ROW_START + i - 1
' RUN COMMANDS
.Cells(r, COL_ERR) = RunTest(awsname, DIR_OUT)
'.Cells(r, COL_ERR) = RunCmd(WShell, awsname, DIR_OUT)
.Cells(r, COL_TS) = Format(Now, "yyyy-mm-dd HH:MM:SS") ' timestamp
Next
Set WShell = Nothing
'Write how many batch files were run into worksheet
.Cells(2, 3) = "Number of batch files run is " & UBound(arNames)
' read text files with FSO, parse with regex
Dim FSO As Object, ts As Object, regex As Object, txt As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set regex = CreateObject("VBScript.RegExp")
With regex
.Global = False
.MultiLine = True
.IgnoreCase = True
.Pattern = "with error code (\d+)"
End With
n = 0
' process text file
For i = 1 To UBound(arNames)
r = ROW_START + i - 1
awsname = arNames(i, 1)
txtfile = DIR_OUT & awsname & ".txt"
result = ""
' does file exist for this machine
If FSO.fileExists(txtfile) Then
' read file
n = n + 1
Set ts = FSO.openTextfile(txtfile)
txt = ts.readall
ts.Close
' extract error number from text
If regex.test(txt) Then
result = regex.Execute(txt)(0).submatches(0)
End If
' error codes
If result = "0" Then
colour = RGB(0, 255, 0) ' green
Else
colour = RGB(255, 255, 0) ' yellow
End If
Else
result = "No Text File"
colour = RGB(255, 0, 0) ' red
End If
' result
With .Cells(r, COL_RESULTS)
.Value2 = result
.Interior.Color = colour
End With
Next
.Cells(3, 3) = "Number of txt files found is " & n
.Columns.AutoFit
End With
MsgBox "Text files found for " & n, vbInformation, Format(Timer - t0, "0.0 secs")
End Sub
Function RunTest(awsname As String, folder As String) As String
Dim FSO, ts, errno: Set FSO = CreateObject("Scripting.FileSystemObject")
If Rnd() < 0.3 Then errno = 0 Else errno = Int(10000 * Rnd())
Set ts = FSO.createTextFile(folder & awsname & ".txt")
ts.write "This is with error code " & errno & "." & vbCrLf & vbCrLf
ts.Close
RunTest = "Test"
End Function
Function RunCmd(WShell, awsname As String, folder As String) As String
MsgBox "RunCmd DISABLED", vbCritical: End
'Const SCRIPT = "D:\min425.cmd"
'Dim cmd: cmd = SCRIPT & " " & awsname
'RunCmd = WShell.Run(cmd, vbNormal, True) ' waittocomplete
End Function
Sub GetFileList()
Dim xFSO As Object
Dim xFolder As Object
Dim xFile As Object
Dim objOL As Object
Dim Msg As Object
Dim xPath As String
Dim thisFile As String
Dim i As Integer
Dim lastrow As Long
xPath = Sheets("UI").Range("D7")
Set xFSO = CreateObject("Scripting.FileSystemObject")
Set xFolder = xFSO.GetFolder(xPath)
i = 1
For Each xFile In xFolder.Files
i = i + 1
Worksheets("Info").Cells(i, 1) = xPath
Worksheets("Info").Cells(i, 2) = Left(xFile.Name, InStrRev(xFile.Name, ".") - 1)
Worksheets("Info").Cells(i, 3) = Mid(xFile.Name, InStrRev(xFile.Name, ".") + 1)
Worksheets("Info").Cells(i, 6) = Left(FileDateTime(xFile), InStrRev(FileDateTime(xFile), " ") - 1)
Next
Set Msg = Nothing
Worksheets("Info").Visible = True
Worksheets("Info").Activate
End Sub
The code to extract file information from a folder. The issue is when I change the folder path, it overwrites on the previously fetched data.
Sheet -UI is where the sub executed on press of button, Sheet Info is the place where the data needs to be pasted.
How to write the code to add a new row of data after the data which is already available. If the sheet is blank then add data from the 1st ROW otherwise add data from the LAST ROW.
Sheets("UI").Range("A1").End(xlDown).Select
i = Selection.Row + 1
Try replacing
i = 1
with
i = Worksheets("Info").UsedRange.Rows.Count + 1
This will set i to 1 the first time around, and to the first free row ever after. New data will be added below the existing data, if there is any.
I am very new to VBA and I'm looking to use it to automate some of my processes. I have looked around this website (and others) and although I find very similar queries, I can't seem to find one that fits my needs exactly.
So far the closest thing I've found to what I'm looking to do is this: Wanting to create a search field and button to trigger VBA script to run
I have a source folder with all my data. My data is stored in multiple text files. Here is an example of what the data in the files looks like:
10001,1,205955.00
10001,2,196954.00
10001,3,4.60
10001,4,92353.00
10001,5,85015.00
10001,6,255.90
10001,7,804.79
10001,8,205955.00
10001,9,32465.00
In each row, the first number is a geographic code, second number is a numeric code for a specific indicator (not important for what I'm trying to do), and the third number is the value I want to import into my spreadsheet. Each geographic code is associated with 2247 rows.
I want to use a search box control in Excel that I can type a specific geographic code into, click a button and then the macro would run, searching the files for that specific code and then importing all the values - in the order they are listed in the data file - into my desired range in the workbook.
So far I've gotten this code written. Again, forgive me if this is bad code... I tried to re-purpose the code from the other forum post I mentioned earlier.
I think I setup the import location right... I want it to import into column C, row 3 of the sheet that the search box/button combo will be present on. But now, I am unsure how I would get the import aspect to work. Thanks in advance for anyone who can help on this issue.
Sub SearchFolders()
Dim FSO As Object
Dim Folder As Object
Dim File As Object
Dim TS As Object
Dim SourceFolder As String
Dim Search As String
Dim LineNumber As Long
Dim DataSh As Worksheet
SourceFolder = "C:\Users\MarMar\Desktop\Data\Census2016\DataFiles\"
Search = TextBox1.Value
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Folder = FSO.GetFolder(SourceFolder)
Set DataSh = ActiveSheet.Cells(3, 3)
For Each File In Folder.Files
Set TS = File.OpenAsTextStream()
LineNumber = 0
Do While Not TS.AtEndOfStream
LineNumber = LineNumber + 1
If InStr(TS.ReadLine, Search) Then
'Code to Import Values to DataSh ???
End If
Loop
TS.Close
Next File
End Sub
Maybe something like this:
Dim arr
For Each File In Folder.Files
Set TS = File.OpenAsTextStream()
LineNumber = 0
Do While Not TS.AtEndOfStream
arr = Split(TS.ReadLine, ",") 'split line to array
'check first element in array
If arr(0) = Search Then
datash.Resize(1, UBound(arr) + 1).Value = arr
Set datash = datash.Offset(1, 0)
End If
Loop
TS.Close
Next File
Final result that worked for me!
Sub SearchImportData1()
Dim FSO As Object
Dim SourceFolder As String
Dim Folder As Object
Dim Import As Range
Dim Search As String
Dim TextBox1 As TextBox
Dim File As Object
Dim TS As Object
Dim LineNumber As Integer
Dim Arr As Variant
SourceFolder = "C:\Users\MarMar\Desktop\Data\Census2016\DataFiles\"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Folder = FSO.GetFolder(SourceFolder)
Set Import = ActiveSheet.Cells(2, 3)
Search = ActiveSheet.TextBox1.Text
For Each File In Folder.Files
Set TS = File.OpenAsTextStream()
LineNumber = 0
Do While Not TS.AtEndOfStream
Arr = Split(TS.ReadLine, ",")
If Arr(0) = Search Then
Import.Resize(1, 1).Value = Arr(2)
Set Import = Import.Offset(1, 0)
End If
Loop
TS.Close
Next File
End Sub
I have a column in a spreadsheet.
The format of the data in each cell is aa-0001-xx.
I need to examine the whole column to find the highest value of the sequence number. this would be the substring from column4 thru column7.
I can find the sequence number using Mid(ActiveWorkbook.Sheets("Sheet1").Range("B2:B2"), 4, 4)
But I need to find the max sequence in the whole column.
I am doing this in VBA.
Any help would be appreciated.
Here is my code so far:
Private Sub CommandButton1_Click()
Dim sQuoteNumber As String
Dim sFileName As String
Dim sPathName As String
Dim checkit As String
'Log the Quote
'First, open the log file and determine the next sequential log number.
sPathName = "C:\Users\Rich\Documents\Bryan\BigProject\"
sFileName = "QuoteLog2016.xlsx"
ControlFile = ActiveWorkbook.Name
Workbooks.Open Filename:=sPathName & sFileName
'Create the new Quote Number
checkit = Mid(ActiveWorkbook.Sheets("Sheet1").Range("B2:B2"), 4, 4) ' This is a temp test line
If Mid(ActiveWorkbook.Sheets("Sheet1").Range("B2:B2"), 4, 4) = "" Then
sQuoteNumber = "16-0001"
Else
'find the biggest number
'Here I was looking to like pass the mid function to a Max function of some sort.
sQuoteNumber = "16-0002"
End If
MsgBox ("The new Quote Number is: " + sQuoteNumber)
'Save the log entry
Workbooks(sFileName).Close
All of the comments made to your answer would work well for you. It's also true that there's no evidence in your code at having attempted something, however rudimentary, and this is why answers to a rather trivial task are not forthcoming for you. Perhaps, in future, have a go at some kind of solution ( even if it feels more guesswork than anything) and people on this site will be much more supportive of you.
To set you on your way, you could make use of the Split() function which converts a String into a String array, separated by a nominated value - in the case of your quotations, you could use "-" as your separator. This might be easier than your Mid function and will deal with the case of different sized quotations.
The code below will get you started but you'd want some error handling in there to test, for example, that each cell splits appropriately or that any cells aren't blank. I'll leave all of that to you.
Option Explicit
Private mLastQuote As Long
Public Sub Test()
Initialise 'call this routine just once at the start of your project
MsgBox GetNextQuote(16) 'use the GetNextQuote() function to get next number
MsgBox GetNextQuote(16)
MsgBox GetNextQuote(16)
End Sub
Private Function GetNextQuote(prefix As Integer) As String
mLastQuote = mLastQuote + 1
GetNextQuote = CStr(prefix) & "-" & _
Format(mLastQuote, "000#")
End Function
Private Sub Initialise()
Const PATH_NAME As String = "C:\Users\Rich\Documents\Bryan\BigProject\"
Const FILE_NAME As String = "QuoteLog2016.xlsx"
Const QUOTE_COL As String = "B"
Dim wb As Workbook
Dim ws As Worksheet
Dim v As Variant
Dim r As Long
Dim parts() As String
Dim num As Long
Application.ScreenUpdating = False
Set wb = Workbooks.Open(PATH_NAME & FILE_NAME, True, True)
Set ws = wb.Worksheets("Sheet1")
'Read quote values into variant array
With ws
v = .Range(.Cells(2, QUOTE_COL), _
.Cells(.Rows.Count, QUOTE_COL).End(xlUp)) _
.Value2
End With
'Find max quote
For r = 1 To UBound(v, 1)
parts = Split(v(r, 1), "-") 'splits quote into 3 parts
num = CLng(parts(1)) 'index (1) is the middle part
If num > mLastQuote Then mLastQuote = num
Next
wb.Close False
Application.ScreenUpdating = True
End Sub
I have a file path (which is a connection path for the worksheet) in the following format:
C:\ExcelFiles\Data\20140522\File1_20140522.csv
I want to extract 20140522.
I tried using responses of How to extract groups of numbers from a string in vba, but they don't seem to work in my case.
please find below
Filename = "C:\ExcelFiles\Data\20140522\File1_20140522.csv"
a = Replace(Mid(Filename, InStrRev(Filename, "_") + 1, Len(Filename)), ".csv", "")
Try the following. Folder is selected.
Sub Folder_S()
Dim sFolder As FileDialog
On Error Resume Next
Set sFolder = Application.FileDialog(msoFileDialogFolderPicker)
If sFolder.Show = -1 Then
Folder_Select sFolder.SelectedItems(1), True
End If
End Sub
Sub Folder_Select(ByVal SourceFolderName As String, ByVal IncludeSubfolders As Boolean)
Dim FSO As Object
Dim SourceFolder As Object
Dim FileItem As Object
Dim strFile As String
Dim FileName As Variant
Dim pathParts() As String
Dim pathPart As String
Dim i As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)
pathParts = Split(SourceFolder.Path, Application.PathSeparator)
pathPart = SourceFolder.Path
For i = 0 To UBound(pathParts)
If pathParts(i) = "20140522" Then
pathPart = pathParts(i - 0)
Exit For
End If
Next i
Row = ActiveCell.Row
With CreateObject("Scripting.Dictionary")
For Each FileItem In SourceFolder.Files
strFile = FileItem.Name
.Item(strFile) = Array(FileItem.Name)
Next FileItem
If .Count > 0 Then
For Each FileName In .Items
Cells(Row, 2).Formula = pathPart
Next FileName
End If
End With
End Sub
I found your question by searching a solution how to get a folder path from a file that is inside this folder path. But your question doesn't match exactly what I need. For those who by your question title will find it for the same purpose as I found, below is my function:
Function getFolderPathFromFilePath(filePath As String) As String
Dim lastPathSeparatorPosition As Long
lastPathSeparatorPosition = InStrRev(filePath, Application.PathSeparator)
getFolderPathFromFilePath = Left(filePath, lastPathSeparatorPosition - 1)
End Function
In some solutions for this purpose, I used FSO, but it takes resources, and I think it isn't worthy to create FSO object if you need it only for this simple function.
the accepted answer is not accurate to read the folder name. here is more dynamic code.
use splitter which splits string based on delimeter and makes an array. now read the second last element in array, thats the folder name.
Dim fileName As String
fileName = "C:\ExcelFiles\Data\20140522\File1_20140522.csv"
Dim vPathSplitter As Variant
vPathSplitter = Split(fileName, "\")
MsgBox (vPathSplitter(UBound(vPathSplitter) - 1))
The below answer gets your file path from a range, rather than a fixed string. Much more handy if your planning on getting your filename from your sheets, which I imagine you are.
Sub GetFileDate()
Dim filename As String
filename = Sheets("Sheet1").Range("C9").Value 'Or Wherever your file path is
MsgBox Replace(Right(filename, 12), ".csv", "")
End Sub
This assumes the numbers your extracting will ALWAYS be dates in YYYYMMDD format and the file type is always .csv