Find a file in folder using different keywords VBA - vba

I am a new to VBA. My issue is that I have a file that will be updated it into a specific folder by different users. Now everytime a user updates the file, the name of the file might not be the samefolder. However, I can narrow it down using specific keywords. I have been able to search for a file using a keyword but not multiple keywords. Please can you point me in the right direction on how I can use multiple keywords to find a file in a folder? Is it possible to write code that will work like the below?
Sub Start_countries()
Dim keyword, pathname, filename As String
pathname = "C:\XYZ\"
keyword = "lol" Or "rofl" Or "lmfao" Or "rotfl"
filename = Dir(pathname & "*.xls*")
Do While filename <> "*.xls*"
If LCase(filename) Like "*" & keyword & "*" Then
Set wb = Workbooks.Open(pathname & filename)
Find_count_sum_in_file filename
wb.Close SaveChanges:=True
Else
msgbox = "No file Found"
End If
Loop
End Sub

Try the following (adapted following your comment):
Private Const MAX_KWD = 5 ' use a constant to make sure everyone uses the same value
Sub Start_countries()
Dim keyword(1 To MAX_KWD), pathname As String
'Keywords for first file search
keyword(1) = "lol"
keyword(2) = "rofl"
keyword(3) = "lmfao"
keyword(4) = "rotfl"
pathname = "C:\XYZ1\"
search_for_files keyword(), pathname
'Keywords for second file search
keyword(1) = "omg"
keyword(2) = "fyi"
keyword(3) = "ok"
keyword(4) = "brb"
pathname = "C:\XYZ2\"
search_for_files keyword(), pathname
End Sub
Sub search_for_files(keyword(), pathname)
Dim filename As String, s As String
Dim i As Integer
filename = Dir(pathname & "*.xls*")
Do While InStr(filename, ".xls") <> 0
s = LCase(filename)
For i = 1 To MAX_KWD
If (InStr(s, keyword(i)) > 0) Then Exit For ' found!
Next i
If (i <= MAX_KWD) Then
Set WB = Workbooks.Open(pathname & filename)
Find_count_sum_in_file filename
WB.Close SaveChanges:=True
Else
MsgBox "No file Found"
End If
filename = Dir()
Loop
End Sub
Note that in Dim pathname, filename, s As String only s is declared as String; all others are declared as Variant (the As String does not apply to all variables declared on the line).
Note also that in your While filename <> "*.xls*" the test will be exact, i.e. it will look also for asterisks (*) in filename.

Related

VBA attempting to open file which name contains characters above high-ascii (256)

What I'd like to achieve is opening a file from the previously-stored variable. The problem is the filename sometimes contains characters like ŰŐ. VBA environment changes them to the closest one UO. So I'm unable to open a workbook included with "special" characters. What I have tried so far:
Sub open_last_modified()
Dim fso As New FileSystemObject
Dim files, folder, lmfile As String
Dim lmdate As Date
' a file previously created on desktop ( like őőőűűű.xlsx)
' with a proper filename, both method works very well
folder = ("C:\Users\szidzse\Desktop\")
files = Dir(folder & "*.*", vbNormal)
Do While files <> ""
On Error Resume Next 'if it contains non
If FileDateTime(folder & files) > lmdate Then
lmdate = FileDateTime(folder & files)
lmfile = files 'the last modified file what i'd like to open even if it has non-ascii characters.
End If
files = Dir
Loop
Set a = Workbooks.Open(folder & lmfile, ReadOnly:=True) 'does nothing when filename is not proper.
fso.CopyFile Source:=folder & lmfile, Destination:=folder & "temp.xlsx" 'file not found (I've tried to copy and rename it to a proper name.)
End Sub
I've also tried StrConv(string, vbFromUnicode or vbUnicode) without success.
Any help will be appreciated.
Please, test the next function. It should replace the non ASCII characters with similar ones:
Function replaceNonASCIICh(x As String) As String
Dim i As Long
For i = 1 To Len(x)
If AscW(Mid(x, i, 1)) <> Asc(Mid(x, i, 1)) Then
x = Replace(x, Mid(x, i, 1), Chr(Asc(Mid(x, i, 1))))
End If
Next i
replaceNonASCIICh = x
End Function
I tested it on the two not ASCII characters we could see/copy, in the next way:
Sub testReplaceNonASCII()
Dim x As String, result As String
x = ChrW(368) & ChrW(79) 'the string containing the characters you show us
result = replaceNonASCIICh(x)
ActiveCell.Offset(1).Value = result 'in Immediate Window non ASCII characters cannot be seen as they are...
End Sub
I do not know what other characters should be involved. Please, test it on your cases and send some feedback.
Now, supposing that Dir returns all files from the folder, even if their name contain non ASCII characters, you should firstly iterate between all of them and change their names, using the above function (and Name function). If it looks complicated, but if Dir returns them, I will show you how to proceed...
If you share such a file (supposing it is not confidential) I can try testing the code I posted, only supposing that it should work...
Edited:
I copied the workbook you sent in a folder named "InvalidCharacters", like subfolder of the one running the code. Then, I (manually) changed its name adding a suffix and copy it again (keeping the non ASCII characters). Please, do the same and test the following code:
Sub changeNonASCIIFileName()
Dim FSOLibrary As Object, fldObj As Object, fsoFile As Object
Dim foldPath As String, fileName As String, newName As String
Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
foldPath = ThisWorkbook.path & "\InvalidCharacters\"
Set fldObj = FSOLibrary.GetFolder(foldPath)
For Each fsoFile In fldObj.files
On Error Resume Next 'if no characters to be replaced you cannot rename the file...
fsoFile.Name = replaceNonASCIICh(fsoFile.Name)
On Error GoTo 0
Next
End Sub
It uses the above function. Please, take care to be there!
I would like to receive some feedback after testing it...
#FaneDuru sorry for my late response.
Your code works, for me, it returns uo instead of űő. But gives File not found. when attempting to open. In my special case for opening a file, putting a question mark where the invalid character is doing the trick.
Workbooks.Open("C:\Users\User\invalid??.xlsx") opens successfully the file named: invalidűő.xlsx
Getting that file's last modified date is a bit trickier,if I tried to store as string it runs into error, file not found, so it must be done via FSO and a lot of mess with the strings, and telling the editor that "Hey this is from Middle European code table!!" so in my case:
Chr(254) is ő in the mid-euro table. If your string contains this char in the editor it handles as the following.
Chr(254) is õ in the western table.
Setting the string with the specified Unicode hex code here ChrW$(&H151) is the key. (Accented o letter). While Chr(254) is (o letter with tilde, or without).
Sub lmfile_check2()
Dim files As String
Dim folder As String
Dim lmdate As Date
Dim lmfile As String
files = Empty
For i = 1 To 11
folder = ThisWorkbook.Sheets(1).Cells(i, 2).Value
files = Dir(folder & "*.*", vbNormal)
Do While files <> ""
On Error Resume Next
If FileDateTime(folder & files) = Empty Then GoTo 2
On Error GoTo 2
lmdate_2:
If FileDateTime(folder & files) > lmdate Or lmdate2 > lmdate Then
If IsEmpty(FileDateTime(folder & files)) Then
GoTo ende
End If
lmfile = files '
If lmdate2 > lmdate And lmdate <> Empty Then
lmdate = lmdate2
Else
lmdate = FileDateTime(folder & files)
End If
End If
GoTo ende
2:
If InStr(1, files, "hétfo") > 0 Then 'this section is for known invalid character
Set fs = CreateObject("Scripting.FileSystemObject")
files2 = Replace(files, "hetfo", "hetf" & ChrW$(&H151), 1, -1, vbTextCompare)
l = Len(files2)
files2 = Left(files2, l - 5)
Set f = fs.GetFile(folder & files2 & ChrW$(&H151) & ".xls")
lmdate2 = f.DateLastModified
If lmdate2 > lmdate Then
lmdate = lmdate2
lmfile = Replace(files, "hetfo", "hetf" & "?", 1, -1, vbTextCompare)
GoTo vege
End If
End If
GoTo lmdate_2
ende:
files = Dir
Loop
ThisWorkbook.Sheets(1).Cells(i, 1) = folder & lmfile
ThisWorkbook.Sheets(1).Cells(i, 4) = lmdate
Set f = Nothing
lmdate = Empty
lmfile = Empty
Next i
For i = 1 To 11
ThisWorkbook.Sheets(1).Cells(i, 1) = Replace(ThisWorkbook.Sheets(1).Cells(i, 1), "hétfo", "hétf" & "?", 1, -1, vbTextCompare)
Next i
MsgBox "Vertig"
End Sub

Changing path to parent directory of active working folder

I have a code that is list files in directory. how can I address code to look into parent directory of current workbook directory? i want it to be independent wherever I place it.
(first code addressing to the second one to read file from)
Thanks.
....
Application.ScreenUpdating = False
ShowPDFs "C:\Test\Working\", ws
ws.UsedRange.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
------------------------------
Private Sub ShowPDFs(ByRef fsoPath.......
Just check that the file is not at root level:
....
Application.ScreenUpdating = False
ShowPDFs ThisWorkbook.Path & "\..", ws
ws.UsedRange.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
------------------------------
Private Sub ShowPDFs(ByRef fsoPath.......
The solution you want:
If your behavior is to open an excel window and then open your recent file, please note that you should not forget to add change Drive and then change Directory into your VBA code.
Cause the Excel always start with the default Directory even it's just open your recent file !
Then, these should be help.
Solution A: You don't need to get parent directory to do anything else.
Dim ThisWorkbookPath As String
Dim ThisWorkbookPathParts As Variant
ThisWorkbookPath = ThisWorkbook.Path
ThisWorkbookPathParts = Split(ThisWorkbookPath, _
Application.PathSeparator)
ChDrive ThisWorkbookPathParts(LBound(ThisWorkbookPathParts))
ChDir ThisWorkbookPath
Solution B: You may need to get parent directory to do things else.
Dim ParentPath As String: ParentPath = "\"
Dim ThisWorkbookPath As String
Dim ThisWorkbookPathParts, Part As Variant
Dim Count, Parts As Long
ThisWorkbookPath = ThisWorkbook.Path
ThisWorkbookPathParts = Split(ThisWorkbookPath, _
Application.PathSeparator)
Parts = UBound(ThisWorkbookPathParts)
Count = 0
For Each Part In ThisWorkbookPathParts
If Count > 0 Then
ParentPath = ParentPath & Part & "\"
End If
Count = Count + 1
If Count = Parts Then Exit For
Next
MsgBox "File-Drive = " & ThisWorkbookPathParts _
(LBound(ThisWorkbookPathParts))
MsgBox "Parent-Path = " & ParentPath

Can't write to zip File if using a string or variant in Shell.Application Copyhere

I am having troubles with NameSpace CopyHere function. I am trying to create a zip file containing a bunch of logs. I can create the zip file just fine, but when using the NameSpace.CopyHere, if I use a string or a variant containing a string, it won't write the file to the zip archive.
For example, I have a file located at P:\test2.txt .
If I use those lines :
objApp.Namespace(sZipArchive).CopyHere sFile
objApp.Namespace(sZipArchive).CopyHere vLogs(i)
where sFile = vLogs(i) = "P:\test2.txt
the file test2.txt won't be copied in the zip archive.
However, if I use this line :
objApp.Namespace(sZipArchive).CopyHere "P:\test2.txt"
Then, the file gets copied in the zip file.
If I put a check to see if the sFile or vLog(i) is = "P:\test2.txt", I can see that they are the same thing.
Is there something I am missing here on why the first 2 lines don't work, but the third one does?
Thank you for your time.
Full sub :
Private Sub BtnSaveToZip_Click()
Dim bEndRow, bTest As Boolean
Dim iRow, iCount As Integer
Dim sZipArchive, sDate, sFolderExists, sFile As String
Dim vLogs, vFilename As Variant
Dim objApp As Object
sDate = Date
sDate = Replace(sDate, "/", "") ' set date format to DDMMYYYY instead of DD/MM/YYYY
sZipArchive = LblLogArchive + "\" + sDate
sFolderExists = Dir(sZipArchive)
If sFolderExists = "" Then
CreateDir (sZipArchive) ' if the subfolder with the date does not exists, create it
End If
sZipArchive = sZipArchive + "\" + wsContacts.Range("B7").Value + " Logs_" + sDate + ".zip"
'Check if file is open
If FileLocked(sZipArchive) Then
MsgBox sZipArchive + " already open. Please close the archive."
Exit Sub
End If
'Creating the zip file from Ron de Bruin
NewZip (sZipArchive)
'filling the zip file
Set objApp = CreateObject("Shell.Application")
bEndRow = False
iRow = gFirstData
Do While bEndRow = False
If Not IsEmpty(wsLogs.Cells(iRow, gTestCase).Value) Then
If Not IsEmpty(wsLogs.Cells(iRow, gLog).Value) Then
vLogs = Split(wsLogs.Cells(iRow, gLog).Value, ";")
For i = 0 To UBound(vLogs) - 1
sFile = vLogs(i) ' Debug only
If sFile = "P:\test2.txt" Then 'Debug only
objApp.Namespace(sZipArchive).CopyHere vLogs(i) ' if I put "P:\test2.txt", it works correctly
'Keep script waiting 5s for debug purpose
Application.Wait (Now + TimeValue("00:00:05"))
End If
Next
End If
iRow = iRow + 1
Else
bEndRow = True
End If
Loop
MsgBox "Zip successfully created"
Set objApp = Nothing
End Sub
If this works
objApp.Namespace(sZipArchive).CopyHere "P:\test2.txt"
and sFile and vLogs(i) appears to be the same as P:\test2.txt then I believe it could be a leading or trailing space problem. Try this
objApp.Namespace(sZipArchive).CopyHere Trim(sFile)
or
objApp.Namespace(sZipArchive).CopyHere Trim(vLogs(i))
The other way to check if sFile and vLogs(i) contains a valid path is by using DIR
One more way of debugging is to step through your code and then type this in the Immediate window
?=vLogs(i)="P:\test2.txt"
?=sFile="P:\test2.txt"
You should get a true in both cases. If you don't then there is your problem :)

Replace Third line of each file inside a folder with second line using Macros

I am using the below VBA code to replace few words in all the files inside one folder.in the same VBA code is it possible to copy the third line of each file and replace it with the second line.
Sub ReplaceStringInFile1()
Dim objFSO As Object, objFil As Object, objFil2 As Object
Dim StrFileName As String, StrFolder As String, strAll As String, newFileText As String
Set objFSO = CreateObject("scripting.filesystemobject")
StrFolder = "I:\Documents\ABC\AZ\"
StrFileName = Dir(StrFolder & "*.txt")
Do While StrFileName <> vbNullString
Set objFil = objFSO.opentextfile(StrFolder & StrFileName)
strAll = objFil.readall
objFil.Close
Set objFil2 = objFSO.createtextfile(StrFolder & StrFileName)
'change this to that in text
newFileText = Replace(strAll, "To:", "FROM")
'change from to to in text
newFileText = Replace(newFileText, "THIS", "THAT")
'write file with new text
'change from to to in text
newFileText = Replace(newFileText, "IS", "WAS")
'write file with new text
objFil2.Write newFileText
objFil2.Close
StrFileName = Dir
Loop
End Sub
I will tell you logic and use the logic accordingly and come up with the code if you got any issues.
Open Each Text file ForReading and read each line one by one using ReadLine and Check for end of stream using AtEndOfStream. Copy each line in one string but skip the second the line. Something like this
Do While Obj.AtEndOfStream <> True
Str = Obj.ReadLine
if i = 2 Then
Str = ""
Else
StrF = StrF & Vbcrlf & Str
End If
i = i + 1
Loop
Now Open the Text File ForWritingReplace the old text in files Using Obj.Write StrF and Close the file. Do the loop for all files in the folder.
Hope This Helps :)

How do I open a file if I only know part of the file name?

I need to open a file whose full filename I do not know.
I know the file name is something like.
filename*esy
I know definitely that there's only one occurrence of this file in the given directory.
filename*esy is already a "shell ready" wildcard & if thats alway the case you can simply;
const SOME_PATH as string = "c:\rootdir\"
...
Dim file As String
file = Dir$(SOME_PATH & "filename*esy" & ".*")
If (Len(file) > 0) Then
MsgBox "found " & file
End If
Just call (or loop until empty) file = Dir$() to get the next match.
There is an Application.FileSearch you can use (see below). You could use that to search for the files that match your pattern. This information taken from here.
Sub App_FileSearch_Example()
With Application.FileSearch
.NewSearch
.LookIn = "c:\some_folder\"
.FileName = "filename*esy"
If .Execute(SortBy:=msoSortByLastModified, SortOrder:=msoSortOrderDescending) > 0 Then
For i1 = 1 To .FoundFiles.Count
' do something with matched file(s)
Next i1
End If
End With
End Sub
If InStr(sFilename, "filename") > 0 and InStr(sFilename, "esy") > 0 Then
'do somthing
end if
Or you can use RegEx
Dim RE As Object, REMatches As Object
Set RE = CreateObject("vbscript.regexp")
With RE
.MultiLine = False
.Global = False
.IgnoreCase = True
.Pattern = "filename(.*)esy"
End With
Set REMatches = RE.Execute(sFilename)
REMatches(0) 'find match
I was trying this question as a function. This is the solution that ended up working for me.
Function fileName(path As String, sName As String, ext As String) As Variant
'path is Full path from root. Can also use path = ActiveWorkbook.path & "\"
'sName is the string to search. ? and * are wildcards. ? is for single char
'example sName = "book?" or sName ="March_*_2014*"
'ext is file extention ie .pdf .xlsm .xls? .j*
Dim file As Variant 'Store the next result of Dir
Dim fname() As String 'Dynamic Array for result set
ReDim fname(0 To 0)
Dim i As Integer ' Counter
i = 0
' Use dir to search and store first result
fname(i) = path & Dir(path & "\" & sName & ext)
i = i + 1
'Load next result
file = Dir
While file <> "" 'While a file is found store that file in the array
ReDim Preserve fname(0 To i) As String
fname(i) = path & file
file = Dir
Wend
fileName = Application.Transpose(fname) 'Print out array
End Function
This works for me as a single or array function.
If you know that no other file contains "filename" and "esy" in that order then you can simply use
Workbooks.Open Filename:= "Filepath\filename*esy.*"
Or if you know the number of missing characters then (assuming 4 characters unknown)
Workbooks.Open Filename:= "Filepath\filename????esy.*"
I use this method to run code on files which are date & timestamped to ignore the timestamp part.