In the code below I could wrote a code to display filenames from a folder. The problem is now that I should display them in the correct Row. For now they are displayed in random sequence and that is not the purpose.
In column "A" the filenames to search for are called with similar name format PBM12.T5.103.
The actual filename to find is called with similar name format 1_29_PBM_12_T5__103.
I have to find a solution to compare "only" the Fat marked letters and numbers like displayed here above, without . or _
As you will see PBM12T5103 is returning in both namestructures.
Please don't try fixed length counts because the filenames are dynamic and the amount of letters are variable. The comparison of the SUBSTITUTED length of column "A" ( PBM12T5103) is the key to comparison but I can not handle to establish this comparison.
When the filename in column "A" has been found, in column "C" the full filename of found file has to be displayed as the original format 1_29_PBM_12_T5__103
Maybe a solution can be found when extra columns can be made to establish the comparison?
In Excel I could approach a solution, but this will not work automized like it should do.
I made the LEN(count dynamic), but this is still no solution to display the full filenames in the required row...
Hopefully somebody can help me out ..
Option Explicit
Sub fileNames_in_folder()
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Dim fldpath
Dim fld As Object, fil As Object, fso As Object, j As Long
fldpath = "C:\"
On Error Resume Next
Thisworkbook.Sheets("1").Activate
'start count row
j = 11
Set fso = CreateObject("scripting.filesystemobject")
Set fld = fso.getfolder(fldpath)
For Each fil In fld.Files
'here I have to add an IF statement in order to compare the filenames written in column "A" with files from folderPath C:\"
'When the correct files is found it should be displayed in column "C"
If
then
Cells(j, 34).Value = fso.GetBaseName(fil.path)
End If
'count behaviour
j = j + 1
Next
Columns("AH").AutoFit
End Sub
I will suggest you different way of getting file names. Instead of FileSystemObject let's use simple Dir function which allows to check the pattern of file name.
1) Files in my testing folder are as follows
2) I assumed that file pattern is as follows:
XXXY.Z.W
where:
XXX > 3 letters text
Y > any length number/text
Z > any length number/text
W > any length number/text
3) The code of subroutine is placed in 2013-06-01...xlsm file which you could see in the pic above (the same folder where your files are). Code is as follows (change where appropriate):
Sub solution()
Dim j As Long, LastRow As Long
Dim fldPath
'your path below
fldPath = ThisWorkbook.Path
ChDir fldPath
Dim arrPattern As Variant
Dim filName As String
For j = 1 To Range("A1").End(xlDown).Row
arrPattern = Split(Cells(j, "A"), ".")
'I suggest to use different way of checking _
pattern of file name. Pattern rules:
'*YYY*XX*Z*W*
filName = Dir("*" & Left(arrPattern(0), 3) & "*" & _
Mid(arrPattern(0), 4) & "*" & _
arrPattern(1) & "*" & _
arrPattern(2) & "*")
If Len(filName) > 0 Then
Cells(j, "B") = filName
Else
Cells(j, "B") = "not found"
End If
Next j
End Sub
4) results are presented in the picture below:
Related
Below is the code so far
I often times have to check if a Purchase Order has been saved in a directory, there could be hundreds of purchase orders listed in Excel.
As the Workbook changes, so often does the filepath.
As such, I would like to make a function that asks for a cell value that contains a string for the filepath, and then a a cell for the PO #.
I'm a little stumped on how best to past information from the Excel sheet. I need a cell reference for the filepath to the directory, and a cell reference for the PO #.
I've been able to make this work with a subroutine, that is what is posted below. This is the third VBA Program I've worked on, please let me know if there is more legwork I should do before posting this:
Dim directory As String
Dim TempfileName As String
Dim i As Long
Dim x As Long
Sub Check_PO()
x = 2
Application.ScreenUpdating = False
For x = 2 To 673
While Cells(x, 14) = 0
x = x + 1
Wend
i = Cells(x, 14)
TempfileName = "\\network\file\name\here\" & "*" & i & "*.pdf"
directory = Dir(TempfileName, vbNormal)
While directory <> ""
Cells(x, 18) = "Matched"
directory = Dir
Wend
Next x
End Sub
Here's a simple UDF:
Public Function HaveReport(fPath As String, fileName As String)
HaveReport = IIf(Dir(fPath & fileName, vbNormal) <> "", _
"Matched", "Not Matched")
End Function
Usage:
Here you have some information regarding my Excel file so you know better my worksheet layout:
it is a normal excel sheet (.xlsx) which starts at row 5 and has many different entries for a table.
Some of this entries are automatically calculated from a function which uses values from cells from the same row.
The document goal is to be a template, so the number of rows containing information may vary depending who is using the template.
Even though the number of rows containing information may vary the functions have to be present at all cells in a column, so whenever someone places a new entry to the table it is automatically calculated.
The formulas are all of them like this: " = if ( #cellvalue <> ""# ; #dosomething# ; #""#) ", which mainly places an empty string if no value is present in a cell, and does someting else if a value is entered.
The template will be cell protected, so only some cells would be able to be modified.
During the last days I've been trying to implement a Button for excel which does the following things on click:
Detect which rows contain table entries, but discarting the rows which contain no manually entered values and may only contain the function stated on the previous paragraph. The table always start at raw 5 but might end at row 50 or 60 or whenever the person who uses it stops to manually enter new entries to the table. It is possible that only the row 5 contains information, but it can never happen that any entry is present in the table.
Create a new ".csv" file, containing only the previously selected rows, on the same folder as the ".xlsx" file which is being used as a template. The ".csv" file name must be the same as the ".xlsx" file, but appending some information present in some specific cells (for example information present in cell A1, B1, A3, C3). The information to be appended will always be string text which will never come from a function output but from manually entered by the keypad. It could be that some of this cells contain no information (empty strings such as: "").
The button action should directly save the file in the same directory where the template is without opening a dialog to save the file. The button should also prompt a dialog in case the name being used for the ".csv" file already exists as a "filename.csv" file in the same folder. This prompted dialog should ask if you would like to overwrite the existing file with the same name with the new one.
Written without Excel on my current PC so you'll need to tinker a bit but something like this:
' Rows that contain entries:
' assuming data is in column A (i.e. col 1)
Dim rowHolderArray() as long
Dim lastRow as long
lastRow = range("A65000").End(xlUp).Row
Redim rowHolderArray(lastRow)
For x = 1 to lastRow
If cells(x,1) <> "" then rowHolderArray(x) = x
next x
2) to populate the csv, create it using the AddWorkbook method then do something like:
Dim rowCounter as long
rowCounter = 1
For x = 0 to UBound(rowHolderArray) - 1
If rowHolderArray(x) <> "" then
cells(rowCounter, 1) = rowHolderArray(x)
rowCounter = rowCounter + 1
End if
Next x
3) To save the book use Application.ActiveWorkbook.Path & "/" & yourWorkBook.name & ".xlsx"
Thanks to everyone, finally I could implement what I wanted. Here you have my example code so you can check it:
Private Sub CommandButton1_Click()
Dim i As Boolean
Dim j As Integer
Dim currentworkbook As String
Dim currentpath As String
Dim csvfilename As String
Dim contentrange As Range
Dim researchername As String
Dim projectname As String
Dim aditional_info As String
Dim year As String
Dim month As String
Dim day As String
Dim hour As String
Dim minute As String
Dim WB As Workbook
Application.DisplayAlerts = False
' Calculate which was the last row with information
i = True
j = 12
While i
j = j + 1
If (Application.Cells(j, 2) = "") Then
i = False
j = j - 1
End If
Wend
' Copy the information I wanted to save in a .csv file
Application.Range(Application.Cells(12, 1), Application.Cells(j, 16)).Copy
' Create some variables to manage the path ant some filenames
currentworkbook = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5)
currentpath = Application.ActiveWorkbook.Path
csvfilename = currentworkbook & "_"
researchername = Application.Cells(1, 2)
projectname = Application.Cells(3, 2)
aditional_info = Application.Cells(5, 2)
year = Format(Now(), "yy")
month = Format(Now(), "MM")
day = Format(Now(), "dd")
hour = Format(Now(), "Hh")
minute = Format(Now(), "Nn")
' Create a new workbook which will be filled with the information copied and then saved as a .csv file.
Set WB = Workbooks.Add
With WB
.Title = "mytitle"
.Subject = "Mysubject"
.Sheets(1).Select
ActiveSheet.Paste
.SaveAs currentpath & "\" & csvfilename & "_" & year & "-" & month & "-" & day & "_" & hour & "h" & minute & "m_" & projectname & "_" & researchername & "_" & aditional_info, xlCSV
.Close
End With
Application.DisplayAlerts = True
End Sub
Using Microsoft Excel 2010, this macro searches for a list of phrases within a folder of text reports. For each phrase, it searches all of the reports and lists each report that contains the phrase.
I found some better macros to do each part of the macro - such as enumerating a directory, or finding a phrase within a text file - although I had a really hard time putting them together successfully. Despite it not being perfect, it may be helpful for others with the same problem, and I hope for some feedback on how to improve and optimize the macro.
Basic overview:
Column A: list of full path to text reports (for instance, "C:\path\to\report.txt")
Column B: name of report (such as "report.txt")
Column C: list of phrases to search for
Columns D+: output showing each report that contains the phrase (column C)
Areas for improvement:
Make the macro run faster! (This took over an hour for 360 reports and 1100 phrases)
Select the reports and report folder from a pop-up or other function (currently entered into the spreadsheet using another macro)
Filter reports by file name (for instance, only check reports with a word or phrase in the file name)
Filter reports by file extension (for instance, only check .txt files and not .xlsx files)
Detect the number of reports and phrases (currently this is hard coded)
Other suggestions / areas for improvement
Code:
Sub findStringMacro()
Dim fn As String
Dim lineString As String
Dim fileName As String
Dim searchTerm As String
Dim findCount As Integer
Dim i As Integer
Dim j As Integer
For i = 2 To 1109
searchTerm = Range("C" & i).Value
findCount = 0
For j = 2 To 367
fn = Range("A" & j).Value
fileName = Range("B" & j).Value
With CreateObject("Scripting.FileSystemObject").OpenTextFile(fn)
Do While Not .AtEndOfStream
lineString = .ReadLine
If InStr(1, lineString, searchTerm, vbTextCompare) Then
findCount = findCount + 1
Cells(i, 3 + findCount) = fileName
GoTo EarlyExit
End If
Loop
EarlyExit:
.Close
End With
Next j
Next i
End Sub
As #Makah pointed out, you're opening a lot of files, which is slow. To fix this, change the order of the loops (see the code below). This will switch from 407,003 file opens to 367. Along the same lines, lets create the FileSystemObject once, instead of once per file open.
Also, VBA is surprisingly slow at reading/writing data from/to Excel. We can deal with this by loading largw blocks of data into VBA all at once with code like
dim data as Variant
data = Range("A1:Z16000").value
And then writing it back to Excel in a large block like
Range("A1:Z16000").value = data
I have also added in code to dynamically check the dimension of your data. We assume that the data starts in cell A2, and if A3 is empty, we use the single cell A2. Otherwise, we use .End(xlDown) to move down to just above the first empty cell in column A. This is the equivalent of pressing ctrl+shift+down.
Note: the following code has not been tested. Also, it requires a reference to "Microsoft Scripting Runtime" for the FileSystemObjects.
Sub findStringMacro()
Dim fn As String
Dim lineString As String
Dim fileName As String
Dim searchTerm As String
Dim i As Integer, j As Integer
Dim FSO As Scripting.FileSystemObject
Dim txtStr As Scripting.TextStream
Dim file_rng As Range, file_cell As Range
Dim output As Variant
Dim output_index() As Integer
Set FSO = New Scripting.FileSystemObject
Set file_rng = Range("A2")
If IsEmpty(file_rng) Then Exit Sub
If Not IsEmpty(file_rng.Offset(1, 0)) Then
Set file_rng = Range(file_rng, file_rng.End(xlDown))
End If
If IsEmpty(Range("C2")) Then Exit Sub
If IsEmpty(Range("C3")) Then
output = Range("C2")
Else
output = Range(Range("C2"), Range("C2").End(xlDown))
End If
ReDim Preserve output(1 To UBound(output, 1), 1 To file_rng.Rows.Count + 1)
ReDim output_index(1 To UBound(output, 1))
For i = 1 To UBound(output, 1)
output_index(i) = 2
Next i
For Each file_cell In file_rng
fn = file_cell.Value 'Range("A" & j)
fileName = file_cell.Offset(0, 1).Value 'Range("B" & j)
Set txtStr = FSO.OpenTextFile(fn)
Do While Not txtStr.AtEndOfStream
lineString = txtStr.ReadLine
For i = 1 To UBound(output, 1)
searchTerm = output(i, 1) 'Range("C" & i)
If InStr(1, lineString, searchTerm, vbTextCompare) Then
If output(i, output_index(i)) <> fileName Then
output_index(i) = output_index(i) + 1
output(i, output_index(i)) = fileName
End If
End If
Next i
Loop
txtStr.Close
Next file_cell
Range("C2").Resize(UBound(output, 1), UBound(output, 2)).Value = output
Set txtStr = Nothing
Set FSO = Nothing
Set file_cell = Nothing
Set file_rng = Nothing
End Sub
I have the following excel vba code to get the txt files from a folder and put them into excel.
Sub testfilelistfromfolder()
Dim varDirectory As Variant
Dim flag As Boolean
Dim i As Integer
Dim strDirectory As String
strDirectory = Application.ActiveWorkbook.Path & "\"
i = 1
flag = True
varDirectory = Dir(strDirectory & "*.txt", vbNormal)
Range("B3:B82").Select
Selection.ClearContents
While flag = True
If varDirectory = "" Then
flag = False
Else
Cells(i + 2, 2) = varDirectory
varDirectory = Dir
i = i + 1
End If
Wend
End Sub
so my question is:
Is there a way to list the txt filenames without the .txt extension?
or should I add a line to trim the names?
something like this:
variable = Left(Sheet1.[A1],InStr(Sheet1.[A1],".")-1)
and if so, how should i adapt this to my original code, where should i put it? is it also possible to replace Sheet1 with the active sheet parameter?How?
thank you very much.
I'd tackle is thusly
Else
sStr = InStr(varDirectory, ".txt")
Cells(i + 2, 2) = Left(varDirectory, sStr - 1)
flNAME = Left(Cells(1, 1).Value,Len(Cells(1, 1).Value)-4)
This grabs the Value of the cell indicated and trims the last for characters off. Obviously if it is not a dot with a three letter extension you will have extra characters. For example, .XLSX would leave the dot.
The code is going to assume that you means the cells of the active sheet. If you want to get data from a different sheet then you need to add code to select the new sheet.
I am not sure what you are trying to use if for so it is hard to say where you will need it in your code at.
Say I have the following path and file name:
P:\...\Annual and Quarterly Budget Data\ECMQA 2012Q1.xls
I want to write an if then statement that does the following (not sure if my statement is set up properly):
If InStr(1, "P:\...\Annual and Quarterly Budget Data\ECMQA 2012Q1.xls", "QA", vbTextCompare) > 0 Then
BD.Sheets("Sheet1").Range("C2").value = "2012Q1"
End If
Instead of just inputting "2012Q1", I want it to automatically read this from the file. The thing is I am actually looping through 12 or so files and there's two types, "ECMQA 2012Q1.xls" (or ECMQB 2012Q2.xls and so on) AND "ECM Annual Budget 2012.xlsx"
If my file is the annual one (If file contains "Annual"), then I want:
BD.Sheets("Sheet1").Range("C2").value = "2012"
And i want it to read this from the actual file, same as the other one...not me putting in "2012"
Is there a way to do this?
Any help will be appreciated!
EDIT:
Here is the loop:
Dim wb As Workbook, sFile As String, sPath As String
Dim itm As Variant
Dim strFileNames As String
sPath = "C:\Actuary\Cash Flow Forecast\Annual and Quarterly Budget Data\"
''Retrieve the current files in directory
sFile = Dir(sPath)
Do While sFile <> ""
strFileNames = strFileNames & "," & sFile
sFile = Dir()
Loop
''Open each file found
For Each itm In Split(strFileNames, ",")
If itm <> "" Then
Set wb = Workbooks.Open(sPath & itm)
''DO LOTS OF CALCULATIONS
'wb.Close True
End If
Next itm
Filesystemobject has a method for extracting the base name from a filename:
Msgbox createobject("scripting.filesystemobject").getbasename("myTest.xlsx") 'myTest
There's lots of ways to get at what you need using split, right, left, mid, or even regex. It really depends on the makeup of the possible source strings and how much variation they contain.
Based soley on your example the following shows various manipulations with the last variable giving "2012"
Sub test()
fPath = "P:\...\Annual and Quarterly Budget Data\ECMQA 2012Q1.xls"
fArray = Split(fPath, "\")
fnamewithtext = fArray(UBound(fArray))
fnamewithoutext = Split(fArray(UBound(fArray)), ".")(0)
ifannual = Left(Split(fArray(UBound(fArray)), " ")(1), 4)
End Sub