Search VBA code across multiple Excel files - excel

I have about 100 macros in a folder, and I'm looking for one in particular that contains a VBA module with function called addGBE - I forget WHICH file it's in though. Is there any software program that allows me to search within the VBA code of files in a specific folder?

Make Windows Search look within MS Office and other Compressed files
Starting with Microsoft Office 2007, the Office Open XML (OOXML) file formats have become the default file format.
File types such as .XLSX, .XLSM and .DOCX use XML architecture and ZIP compression to store things like text and formulas into cells that are organized into rows and columns. For example, simply changing a .XLSM' file's extension to.ZIP` allows you to open it as a compressed file and view the files that make up the Excel workbook.
By tweaking a few settings we can ensure that Windows Search always searches within OOXML and other compressed file formats.
My example uses Windows 7, but Windows 10 has equivalent settings.
Specify which filetypes should be indexed
Hit +E an browse to the folder where you keep your Office or Compressed files are stored.
Hit Alt+T to open the Tools menu and click Folder Options
Specify which filetypes to always search within
Go to the Search tab
Make sure Always search filenames and contents is selected
Make sure Include compressed is checked
Apply change to other folders:
At this point you can either:
repeat the above steps on any other folders on which you want to change these options, or,
go to the View tab and click Apply to Folders to make all folders look/act like the current one.
Caution! This will copy all of the current folder settings to all other folders, including displayed columns, sort order, view, etc., so be aware that you may lose unique setups for individual folders.
Personally, I'll take the time to setup one folder exactly how I like it, and implement everywhere with a single click.
Open Indexing Options:
Hit the Windows Key
Type index click Indexing Options or hit Enter
click Modify to open a filetree to specify which folders should be included in the Index.
I like to include all folders, but this negatively impacts overall performance if you have a ton of data on the drive(s).
In the Indexing Options dialog:
click the Advanced tab
in the Advanced Options dialog, go to the File Types tab.
This is where you specify which filetypes the indexer should always search within.
Go through the list looking for each Open Office XML filetype (like .XLSM and DOCX)
Select Index Properties and File Contents.
Repeat for any compressed filetypes you want to include (such as .ZIP and .RAR)
When finished click OK
]10
Force re-index:
When you're finished customizing the Indexing options:
On the Indexing Options dialog, click Rebuild to build a new index file.
Note that re-indexing can take a really long time to complete, especially if you're actively using the device and/or you have a ton of data stored locally.
You can optionally close the Indexing dialog with the × and the process will continue in the background.

I found some old code (2006) that I've updated. It will open a box to enter search string then open a dir dialog box to select folder. It will then search through all modules and display a msgbox displaying file name and sheet/module name where string was found. I did not make this, just updated. Orig found here. See here for Microsoft documentation on checking for 64bit and declaring data types properly.
Option Explicit
#If VBA7 And Win64 Then ' VBA7
Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Type BROWSEINFO
hOwner As LongPtr
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As LongPtr
lParam As LongPtr
iImage As Long
End Type
#Else ' Downlevel when using previous version of VBA7
Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
#End If
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim R As Long
Dim x As Long
Dim pos As Integer
'Root folder (&H0 for Desktop, &H11 for My Computer)
bInfo.pidlRoot = &H0
'Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If
'Type of directory to return
bInfo.ulFlags = &H1
'Display the dialog
x = SHBrowseForFolder(bInfo)
'Parse the result
Path = Space$(512)
R = SHGetPathFromIDList(ByVal x, ByVal Path)
If R Then
pos = InStr(Path, Chr$(0))
GetDirectory = Left(Path, pos - 1)
Else
GetDirectory = ""
End If
End Function
Function RecursiveFindFiles(strPath As String, _
strSearch As String, _
Optional bSubFolders As Boolean = True, _
Optional bSheet As Boolean = False, _
Optional lFileCount As Long = 0, _
Optional lDirCount As Long = 0) As Variant
'adapted from the MS example:
'http://support.microsoft.com/default.aspx?scid=kb;en-us;185476
'---------------------------------------------------------------
'will list all the files in the supplied folder and it's
'subfolders that fit the strSearch criteria
'lFileCount and lDirCount will always have to start as 0
'---------------------------------------------------------------
Dim strFileName As String 'Walking strFileName variable.
Dim strDirName As String 'SubDirectory Name.
Dim arrDirNames() As String 'Buffer for directory name entries.
Dim nDir As Long 'Number of directories in this strPath.
Dim i As Long 'For-loop counter.
Dim n As Long
Dim arrFiles
Static strStartDirName As String
Static strpathOld As String
On Error GoTo sysFileERR
If lFileCount = 0 Then
Static collFiles As Collection
Set collFiles = New Collection
Application.Cursor = xlWait
End If
If Right$(strPath, 1) <> "\" Then
strPath = strPath & "\"
End If
If lFileCount = 0 And lDirCount = 0 Then
strStartDirName = strPath
End If
'search for subdirectories
'-------------------------
nDir = 0
ReDim arrDirNames(nDir)
strDirName = Dir(strPath, _
vbDirectory Or _
vbHidden Or _
vbArchive Or _
vbReadOnly Or _
vbSystem) 'Even if hidden, and so on.
Do While Len(strDirName) > 0
'ignore the current and encompassing directories
'-----------------------------------------------
If (strDirName <> ".") And (strDirName <> "..") Then
'check for directory with bitwise comparison
'-------------------------------------------
If GetAttr(strPath & strDirName) And vbDirectory Then
arrDirNames(nDir) = strDirName
lDirCount = lDirCount + 1
nDir = nDir + 1
DoEvents
ReDim Preserve arrDirNames(nDir)
End If 'directories.
sysFileERRCont1:
End If
strDirName = Dir() 'Get next subdirectory
DoEvents
Loop
'Search through this directory
'-----------------------------
strFileName = Dir(strPath & strSearch, _
vbNormal Or _
vbHidden Or _
vbSystem Or _
vbReadOnly Or _
vbArchive)
While Len(strFileName) <> 0
'dump file in sheet
'------------------
If bSheet Then
If lFileCount < 65536 Then
Cells(lFileCount + 1, 1) = strPath & strFileName
End If
End If
lFileCount = lFileCount + 1
collFiles.Add strPath & strFileName
If strPath <> strpathOld Then
Application.StatusBar = " " & lFileCount & _
" " & strSearch & " files found. " & _
"Now searching " & strPath
End If
strpathOld = strPath
strFileName = Dir() 'Get next file
DoEvents
Wend
If bSubFolders Then
'If there are sub-directories..
'------------------------------
If nDir > 0 Then
'Recursively walk into them
'--------------------------
For i = 0 To nDir - 1
RecursiveFindFiles strPath & arrDirNames(i) & "\", _
strSearch, _
bSubFolders, _
bSheet, _
lFileCount, _
lDirCount
DoEvents
Next
End If 'If nDir > 0
'only bare main folder left, so get out
'--------------------------------------
If strPath & arrDirNames(i) = strStartDirName Then
ReDim arrFiles(1 To lFileCount) As String
For n = 1 To lFileCount
arrFiles(n) = collFiles(n)
Next
RecursiveFindFiles = arrFiles
Application.Cursor = xlDefault
Application.StatusBar = False
End If
Else 'If bSubFolders
ReDim arrFiles(1 To lFileCount) As String
For n = 1 To lFileCount
arrFiles(n) = collFiles(n)
Next
RecursiveFindFiles = arrFiles
Application.Cursor = xlDefault
Application.StatusBar = False
End If 'If bSubFolders
Exit Function
sysFileERR:
Resume sysFileERRCont1
End Function
Function FileFromPath(ByVal strFullPath As String, _
Optional bExtensionOff As Boolean = False) _
As String
Dim FPL As Long 'len of full path
Dim PLS As Long 'position of last slash
Dim pd As Long 'position of dot before exension
Dim strFile As String
On Error GoTo ERROROUT
FPL = Len(strFullPath)
PLS = InStrRev(strFullPath, "\", , vbBinaryCompare)
strFile = Right$(strFullPath, FPL - PLS)
If bExtensionOff = False Then
FileFromPath = strFile
Else
pd = InStr(1, strFile, ".", vbBinaryCompare)
FileFromPath = Left$(strFile, pd - 1)
End If
Exit Function
ERROROUT:
On Error GoTo 0
FileFromPath = ""
End Function
Sub SearchWBsForCode()
Dim strTextToFind As String
Dim strFolder As String
Dim arr
Dim i As Long
Dim strWB As String
Dim VBProj As VBProject
Dim VBComp As VBComponent
Dim lStartLine As Long
Dim lEndLine As Long
Dim lFound As Long
Dim lType As Long
Dim lSkipped As Long
Dim oWB As Workbook
Dim bOpen As Boolean
Dim bNewBook As Boolean
strTextToFind = InputBox("Type the text to find", _
"finding text in VBE")
If Len(strTextToFind) = 0 Or StrPtr(strTextToFind) = 0 Then
Exit Sub
End If
strFolder = GetDirectory()
If Len(strFolder) = 0 Then
Exit Sub
End If
lType = Application.InputBox("Type file type to search" & _
vbCrLf & vbCrLf & _
"1. Only .xls files" & vbCrLf & _
"2. Only .xla files" & vbCrLf & _
"3. Either file type", _
"finding text in VBE", 1, Type:=1)
Select Case lType
Case 1
arr = RecursiveFindFiles(strFolder, "*.xls", True, True)
Case 2
arr = RecursiveFindFiles(strFolder, "*.xla", True, True)
Case 3
arr = RecursiveFindFiles(strFolder, "*.xl*", True, True)
Case Else
Exit Sub
End Select
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
For i = 1 To UBound(arr)
Application.StatusBar = i & "/" & UBound(arr) & _
" - Searching " & arr(i)
strWB = FileFromPath(arr(i))
On Error Resume Next
Set oWB = Workbooks(strWB)
If oWB Is Nothing Then
bOpen = False
Workbooks.Open arr(i)
Else
'for preventing closing WB's that are open already
bOpen = True
Set oWB = Nothing
End If
bNewBook = True
For Each VBComp In Workbooks(strWB).VBProject.VBComponents
If Err.Number = 50289 Then 'for protected WB's
lSkipped = lSkipped + 1
Err.Clear
GoTo PAST
End If
lEndLine = VBComp.CodeModule.CountOfLines
If VBComp.CodeModule.Find(strTextToFind, _
lStartLine, _
1, _
lEndLine, _
-1, _
False, _
False) = True Then
If bNewBook = True Then
lFound = lFound + 1
bNewBook = False
End If
Application.ScreenUpdating = True
If MsgBox("Workbook: " & arr(i) & vbCrLf & _
"VBComponent: " & VBComp.Name & vbCrLf & _
"Line number: " & lStartLine & _
vbCrLf & vbCrLf & _
"WB's found so far: " & lFound & vbCrLf & _
"Protected WB's skipped: " & lSkipped & _
vbCrLf & vbCrLf & _
"Stop searching?", _
vbYesNo + vbDefaultButton1 + vbQuestion, _
i & "/" & UBound(arr) & _
" - found " & strTextToFind) = vbYes Then
With Application
.StatusBar = False
.EnableEvents = True
.DisplayAlerts = True
End With
With VBComp.CodeModule.CodePane
.SetSelection lStartLine, 1, lStartLine, 1
.Show
End With
Exit Sub
End If
Application.ScreenUpdating = False
End If
Next
PAST:
If bOpen = False Then
Workbooks(strWB).Close savechanges:=False
End If
On Error GoTo 0
Next
On Error Resume Next
If bOpen = False Then
Workbooks(strWB).Close savechanges:=False
End If
With Application
.ScreenUpdating = True
.StatusBar = False
.EnableEvents = True
.DisplayAlerts = True
End With
MsgBox lFound & " WB's found with " & strTextToFind & " in VBE" & _
vbCrLf & vbCrLf & _
"protected WB's skipped: " & lSkipped, , _
"finding text in VBE"
End Sub

Related

Renaming Files in directory not only a folder

I am working on a project in excel, where I am renaming multiple files.
Fow now I am using this code
Sub RenameFiles()
Dim xDir As String
Dim xFile As String
Dim xRow As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = -1 Then
xDir = .SelectedItems(1)
xFile = Dir(xDir & Application.PathSeparator & "*")
Do Until xFile = ""
xRow = 0
On Error Resume Next
xRow = Application.Match(xFile, Range("A:A"), 0)
If xRow > 0 Then
Name xDir & Application.PathSeparator & xFile As _
xDir & Application.PathSeparator & Cells(xRow, "G").Value
End If
xFile = Dir
Loop
End If
End With
End Sub
which lets me change the names of the files in one specific folder, but I would like to be able to pick the main folder containing subfolders and it would change all the names corresponding with names I have made in my excel sheet.
I’m sure you are aware that renaming files if go wrong can have very serious, sometimes even catastrophic consequences, with that been said I hope that all necessary step to avoid any of those problems have been taken.
Data and Code:
It seems that columns A and G contain the "old" and "new" names of the files (excluding the path), and that’s the reason of asking the user for the path and the possibility of running the renaming of the files for subfolders as well.
The code posted compares every file in the folders (and subfolder as expected) against the list of files in the data, which could be time consuming.
Also, I’ll would suggest to have a track of what files have been renamed, so in case of any error, this allows to easily track back and undo what could have be an error.
Solution Proposed
The solution proposed below uses the FileSystemObject object which provides a robust access to the machine file system, you can interact with it in two manners: Early and Late Binding (Visual Basic). These procedures use late binding, to use early binding see How do I use FileSystemObject in VBA?
Folders_ƒGet_From_User: A function that ask the user to select the folder and to process or not subfolders. It returns a list of the subfolder selected (names only), excluding folders with no files.
Files_Get_Array: Creates and array with all the Filenames to be processed (Old & New)
Files_ƒRename: This function renames all files found in any of the folders from the list obtained from point 1. These procedure instead of validating every file present in the subfolders against the list, check if the files in the list Exist in any folder, and if so passes to the function File_ƒRename_Apply that does the renaming and returns the result, allowing the creation of the “Audit Track” array. It returns an array with the results of all the files names in the list in all the folders list ( from point 1 and 2) respectively.
File_Rename_Post_Records: Creates a worksheet named FileRename(Track) (if not present) to post the Audit Track of the results of the Files_ƒRename function.
All of them are called from the procedure: Files_Rename
Let me know of any questions you might have regarding the resources used.
Option Explicit
Private Const mk_Wsh As String = "FileRename(Track)"
Private Const mk_MsgTtl As String = "Files Rename"
Private mo_Fso As Object
…
Sub Files_Rename()
Dim aFolders() As String, aFiles As Variant
Dim aRenamed As Variant
Set mo_Fso = CreateObject("Scripting.FileSystemObject")
If Not (Folders_ƒGet_From_User(aFolders)) Then Exit Sub
Call Files_Get_Array(aFiles)
If Not (Files_ƒRename(aRenamed, aFolders, aFiles)) Then
Call MsgBox("None file was renamed", vbInformation, mk_MsgTtl)
Exit Sub
End If
Call File_Rename_Post_Records(aFiles, aRenamed)
Call MsgBox("Files were renamed" & String(2, vbLf) _
& vbTab & "see details in sheet [" & mk_Wsh & "]", vbInformation, mk_MsgTtl)
End Sub
…
Private Function Folders_ƒGet_From_User(aFolders As Variant) As Boolean
Dim aFdrs As Variant
Dim oFdr As Object, sFolder As String, blSubFdrs As Boolean
Erase aFolders
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show <> -1 Then Exit Function
sFolder = .SelectedItems(1)
End With
If MsgBox("Do you want to include subfolders?", _
vbQuestion + vbYesNo + vbDefaultButton2, _
mk_MsgTtl) = vbYes Then blSubFdrs = True
Set oFdr = mo_Fso.GetFolder(sFolder)
Select Case blSubFdrs
Case False
If oFdr.Files.Count > 0 Then
aFdrs = aFdrs & "|" & oFdr.Path
Else
MsgBox "No files found in folder:" & String(2, vbLf) & _
vbTab & sFolder & String(2, vbLf) & _
vbTab & "Process is being terminated.", _
vbInformation, mk_MsgTtl
Exit Function
End If
Case Else
Call SubFolders_Get_Array(aFdrs, oFdr)
If aFdrs = vbNullString Then
MsgBox "No files found in folder & subfolders:" & String(2, vbLf) & _
vbTab & sFolder & String(2, vbLf) & _
vbTab & "Process is being terminated.", _
vbInformation, mk_MsgTtl
Exit Function
End If
End Select
Rem String To Array
aFdrs = Mid(aFdrs, 2)
aFdrs = Split(aFdrs, "|")
aFolders = aFdrs
Folders_ƒGet_From_User = True
End Function
…
Private Sub SubFolders_Get_Array(aFdrs As Variant, oFdr As Object)
Dim oSfd As Object
With oFdr
If .Files.Count > 0 Then aFdrs = aFdrs & "|" & .Path
For Each oSfd In .SubFolders
Call SubFolders_Get_Array(aFdrs, oSfd)
Next: End With
End Sub
…
Private Sub Files_Get_Array(aFiles As Variant)
Dim lRow As Long
With ThisWorkbook.Sheets("DATA") 'change as required
lRow = .Rows.Count
If Len(.Cells(lRow, 1).Value) = 0 Then lRow = .Cells(lRow, 1).End(xlUp).Row
aFiles = .Cells(2, 1).Resize(-1 + lRow, 7).Value
End With
End Sub
…
Private Function Files_ƒRename(aRenamed As Variant, aFolders As Variant, aFiles As Variant) As Boolean
Dim vRcd As Variant: vRcd = Array("Filename.Old", "Filename.New")
Dim blRenamed As Boolean
Dim oDtn As Object, aRcd() As String, lRow As Long, bFdr As Byte
Dim sNameOld As String, sNameNew As String
Dim sFilename As String, sResult As String
aRenamed = vbNullString
Set oDtn = CreateObject("Scripting.Dictionary")
vRcd = Join(vRcd, "|") & "|" & Join(aFolders, "|")
vRcd = Split(vRcd, "|")
oDtn.Add 0, vRcd
With mo_Fso
For lRow = 1 To UBound(aFiles)
sNameOld = aFiles(lRow, 1)
sNameNew = aFiles(lRow, 7)
vRcd = sNameOld & "|" & sNameNew
For bFdr = 0 To UBound(aFolders)
sResult = Chr(39)
sFilename = .BuildPath(aFolders(bFdr), sNameOld)
If .FileExists(sFilename) Then
If File_ƒRename_Apply(sResult, sNameNew, sFilename) Then blRenamed = True
End If
vRcd = vRcd & "|" & sResult
Next
vRcd = Mid(vRcd, 2)
vRcd = Split(vRcd, "|")
oDtn.Add lRow, vRcd
Next: End With
If Not (blRenamed) Then Exit Function
aRenamed = oDtn.Items
aRenamed = WorksheetFunction.Index(aRenamed, 0, 0)
Files_ƒRename = True
End Function
…
Private Function File_ƒRename_Apply(sResult As String, sNameNew As String, sFileOld As String) As Boolean
With mo_Fso.GetFile(sFileOld)
sResult = .ParentFolder
On Error Resume Next
.Name = sNameNew
If Err.Number <> 0 Then
sResult = "¡Err: " & Err.Number & " - " & Err.Description
Exit Function
End If
On Error GoTo 0
End With
File_ƒRename_Apply = True
End Function
…
Private Sub File_Rename_Post_Records(aFiles As Variant, aRenamed As Variant)
Const kLob As String = "lo.Audit"
Dim blWshNew As Boolean
Dim Wsh As Worksheet, Lob As ListObject, lRow As Long
Rem Worksheet Set\Add
With ThisWorkbook
On Error Resume Next
Set Wsh = .Sheets(mk_Wsh)
On Error GoTo 0
If Wsh Is Nothing Then
.Worksheets.Add After:=.Sheets(.Sheets.Count)
Set Wsh = .Sheets(.Sheets.Count)
blWshNew = True
End If: End With
Rem Set ListObject
With Wsh
.Name = mk_Wsh
.Activate
Application.GoTo .Cells(1), 1
Select Case blWshNew
Case False
Set Lob = .ListObjects(kLob)
lRow = 1 + Lob.ListRows.Count
Case Else
With .Cells(2, 2).Resize(1, 4)
.Value = Array("TimeStamp", "Filename.Old", "Filename.New", "Folder.01")
Set Lob = .Worksheet.ListObjects.Add(xlSrcRange, .Resize(2), , xlYes)
Lob.Name = "lo.Audit"
lRow = 1
End With: End Select: End With
Rem Post Data
With Lob.DataBodyRange.Cells(lRow, 1).Resize(UBound(aRenamed), 1)
.Value = Format(Now, "YYYYMMDD_HHMMSS")
.Offset(0, 1).Resize(, UBound(aRenamed, 2)).Value = aRenamed
.CurrentRegion.Columns.AutoFit
End With
End Sub
Renaming Files (Subfolders)
Not nearly enough tested.
You better create a copy of the folder where it should run to avoid losing files.
It will write all files in the folder and its subfolders to a dictionary object whose keys (file paths) will be checked against the file paths in column A. If matched, the files will be renamed to the name in column G with the same file path.
It checks each new file path only against the file paths in the dictionary before renaming.
It will fail if a file name is not valid.
Copy the complete code to a standard module, e.g. Module1.
Adjust the values in the constants section of the first procedure.
Run only the first procedure, the rest is being called by it.
The Code
Option Explicit
Sub renameFiles()
' Define constants.
Const wsName As String = "Sheet1"
Const FirstRow As Long = 2
Dim Cols As Variant
Cols = Array("A", "G")
Dim wb As Workbook
Set wb = ThisWorkbook
' Define worksheet.
Dim ws As Worksheet
Set ws = wb.Worksheets(wsName)
' Define Lookup Column Range.
Dim rng As Range
Set rng = defineColumnRange(ws, Cols(LBound(Cols)), FirstRow)
' Write values from Column Ranges to jagged Column Ranges Array.
Dim ColumnRanges As Variant
ColumnRanges = getColumnRanges(rng, Cols)
' Pick a folder.
Dim FolderPath As String
FolderPath = pickFolder
' Define a Dictionary object.
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
' Write the paths and the names of the files in the folder
' and its subfolders to the Dictionary.
Set dict = getFilesDictionary(FolderPath)
' Rename files.
Dim RenamesCount As Long
RenamesCount = renameColRngDict(ColumnRanges, dict)
' Inform user.
If RenamesCount > 0 Then
MsgBox "Renamed " & RenamesCount & " file(s).", vbInformation, "Success"
Else
MsgBox "No files renamed.", vbExclamation, "No Renames"
End If
End Sub
Function defineColumnRange(Sheet As Worksheet, _
ColumnIndex As Variant, _
FirstRowNumber As Long) _
As Range
Dim rng As Range
Set rng = Sheet.Cells(FirstRowNumber, ColumnIndex) _
.Resize(Sheet.Rows.Count - FirstRowNumber + 1)
Dim cel As Range
Set cel = rng.Find(What:="*", _
LookIn:=xlFormulas, _
SearchDirection:=xlPrevious)
If Not cel Is Nothing Then
Set defineColumnRange = rng.Resize(cel.Row - FirstRowNumber + 1)
End If
End Function
Function getColumnRanges(ColumnRange As Range, _
BuildColumns As Variant) _
As Variant
Dim Data As Variant
ReDim Data(LBound(BuildColumns) To UBound(BuildColumns))
Dim j As Long
With ColumnRange.Columns(1)
For j = LBound(BuildColumns) To UBound(BuildColumns)
If .Rows.Count > 1 Then
Data(j) = .Offset(, .Worksheet.Columns(BuildColumns(j)) _
.Column - .Column).Value
Else
Dim OneCell As Variant
ReDim OneCell(1 To 1, 1 To 1)
Data(j) = OneCell
Data(1, 1) = .Offset(, .Worksheet.Columns(BuildColumns(j)) _
.Column - .Column).Value
End If
Next j
End With
getColumnRanges = Data
End Function
Function pickFolder() _
As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = -1 Then
pickFolder = .SelectedItems(1)
End If
End With
End Function
' This cannot run without the 'listFiles' procedure.
Function getFilesDictionary(ByVal FolderPath As String) _
As Object
Dim dict As Object ' ByRef
Set dict = CreateObject("Scripting.Dictionary")
With CreateObject("Scripting.FileSystemObject")
listFiles dict, .GetFolder(FolderPath)
End With
Set getFilesDictionary = dict
End Function
' This is being called only by 'getFileDictionary'
Sub listFiles(ByRef Dictionary As Object, _
fsoFolder As Object)
Dim fsoSubFolder As Object
Dim fsoFile As Object
For Each fsoFile In fsoFolder.Files
Dictionary(fsoFile.Path) = Empty 'fsoFile.Name
Next fsoFile
For Each fsoSubFolder In fsoFolder.SubFolders
listFiles Dictionary, fsoSubFolder
Next
End Sub
' Breaking the rules:
' A Sub written as a function to return the number of renamed files.
Function renameColRngDict(ColumnRanges As Variant, _
Dictionary As Object) _
As Long
Dim Key As Variant
Dim CurrentIndex As Variant
Dim NewFilePath As String
For Each Key In Dictionary.Keys
Debug.Print Key
CurrentIndex = Application.Match(Key, _
ColumnRanges(LBound(ColumnRanges)), 0)
If Not IsError(CurrentIndex) Then
NewFilePath = Left(Key, InStrRev(Key, Application.PathSeparator)) _
& ColumnRanges(UBound(ColumnRanges))(CurrentIndex, 1)
If IsError(Application.Match(NewFilePath, Dictionary.Keys, 0)) Then
renameColRngDict = renameColRngDict + 1
Name Key As NewFilePath
End If
End If
Next Key
End Function

Search some text/word in folder containing bunch of PDF files and get count of PDF contains that text/word - Without opening pdf files

Aim - I want VBA code that should search specific text/word in content inside bunch of pdf files and give me COUNT of PDF contains that word (without opening pdf files)
Currently I have code found on internet giving me count of PDF files that contains specific text in the > Name of pdf files <
But as mentioned I want to modify below code/give me new code that should give me COUNT of pdf files contains that specific word inside the PDF content
Below is the current code I have
Sub PDFCONTENT()
Dim i As Long
Dim x As Integer
Dim Folder As String
Dim ExcelFN As String
Dim NumFiles As Integer
Dim filename As String
Dim FinsS As String
For i = 2 To Range("A" & Rows.count).End(xlDown).Row
NumFiles = 0
Folder = Sheets("Sheet1").Range("A" & i).Value
ExcelFN = Sheets("Sheet1").Range("B" & i).Value
filename = Dir(Folder & "*" & ExcelFN & "*")
Do While filename <> ""
NumFiles = NumFiles + 1
filename = Dir()
Loop
Sheets("Sheet1").Range("C" & i) = NumFiles
Next i
End Sub
I don't see how you will get the content of the PDF files, or any files for that matter, without opening the files. Also, you will need Adobe Acrobat installed to scan PDF files using VBA. I don't know how much it costs, but it's not free. If you want a free option, convert all PDF files into Word files and then do scans on those.
Sub ConvertToWord()
Dim MyObj As Object, MySource As Object, file As Variant
file = Dir("C:\Users\Excel\Desktop\test\" & "*.pdf") 'pdf path
Do While (file <> "")
ChangeFileOpenDirectory "C:\Users\Excel\Desktop\test\"
Documents.Open FileName:=file, ConfirmConversions:=False, ReadOnly:= _
False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:= _
"", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", _
Format:=wdOpenFormatAuto, XMLTransform:=""
ChangeFileOpenDirectory "C:\Users\Excel\Desktop\test\" 'path for saving word
ActiveDocument.SaveAs2 FileName:=Replace(file, ".pdf", ".docx"), FileFormat:=wdFormatXMLDocument _
, LockComments:=False, Password:="", AddToRecentFiles:=True, _
WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False, CompatibilityMode:=15
ActiveDocument.Close
file = Dir
Loop
End Sub
Then, run this code below, in Excel.
Sub OpenAndReadWordDoc()
Rows("2:1000000").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("A1").Select
' assumes that the previous procedure has been executed
Dim oWordApp As Word.Application
Dim oWordDoc As Word.Document
Dim blnStart As Boolean
Dim r As Long
Dim sFolder As String
Dim strFilePattern As String
Dim strFileName As String
Dim sFileName As String
Dim ws As Worksheet
Dim c As Long
Dim n As Long
Dim iCount As Long
Dim strSearch As String
'~~> Establish an Word application object
On Error Resume Next
Set oWordApp = GetObject(, "Word.Application")
If Err Then
Set oWordApp = CreateObject("Word.Application")
' We started Word for this macro
blnStart = True
End If
On Error GoTo ErrHandler
Set ws = ActiveSheet
r = 1 ' startrow for the copied text from the Word document
' Last column
n = ws.Range("A1").End(xlToRight).Column
sFolder = "C:\Users\Excel\Desktop\test\"
'~~> This is the extension you want to go in for
strFilePattern = "*.doc*"
'~~> Loop through the folder to get the word files
strFileName = Dir(sFolder & strFilePattern)
Do Until strFileName = ""
sFileName = sFolder & strFileName
'~~> Open the word doc
Set oWordDoc = oWordApp.Documents.Open(sFileName)
' Increase row number
r = r + 1
' Enter file name in column A
ws.Cells(r, 1).Value = sFileName
ActiveCell.Offset(1, 0).Select
ActiveSheet.Hyperlinks.Add Anchor:=Sheets("Sheet1").Range("A" & r), Address:=sFileName, _
SubAddress:="A" & r, TextToDisplay:=sFileName
' Loop through the columns
For c = 2 To n
If oWordDoc.Content.Find.Execute(FindText:=Trim(ws.Cells(1, c).Value), _
MatchWholeWord:=True, MatchCase:=False) Then
strSearch = ws.Cells(1, c).Value
iCount = 0
With ActiveDocument.Content.Find
.Text = strSearch
.Format = False
.Wrap = wdFindStop
Do While .Execute
iCount = iCount + 1
Loop
End With
ws.Cells(r, c).Value = iCount
End If
Next c
oWordDoc.Close SaveChanges:=False
'~~> Find next file
strFileName = Dir
Loop
ExitHandler:
On Error Resume Next
' close the Word application
Set oWordDoc = Nothing
If blnStart Then
' We started Word, so we close it
oWordApp.Quit
End If
Set oWordApp = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
Function GetDirectory(path)
GetDirectory = Left(path, InStrRev(path, "\"))
End Function
Here, the counts are the same because I copied/pasted the same file 4x so I had something to loop over.

URLDownloadToFile Error: INET_E_SECURITY_PROBLEM

I'm modifying code to download multiple files via Excel VBA.
The code is as follows:
Option Explicit
'API function declaration for both 32 and 64bit Excel.
#If VBA7 Then
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long
#Else
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long
#End If
Sub DownloadFiles()
'--------------------------------------------------------------------------------------------------
'The macro loops through all the URLs (column C) and downloads the files at the specified folder.
'The characters after the last "/" of the URL string are used to create the file path.
'If the file is downloaded successfully an OK will appear in column D (otherwise an ERROR value).
'The code is based on API function URLDownloadToFile, which actually does all the work.
'Written By: Christos Samaras
'Date: 02/11/2013
'Last Update: 06/06/2015
'E-mail: xristos.samaras#gmail.com
'Site: https://myengineeringworld.net/////
'--------------------------------------------------------------------------------------------------
'Declaring the necessary variables.
Dim sh As Worksheet
Dim DownloadFolder As String
Dim LastRow As Long
Dim SpecialChar() As String
Dim SpecialCharFound As Double
Dim FilePath As String
Dim i As Long
Dim j As Integer
Dim Result As Long
Dim CountErrors As Long
'Disable screen flickering.
Application.ScreenUpdating = False
'Set the worksheet object to the desired sheet.
Set sh = Sheets("Sheet1")
'An array with special characters that cannot be used for naming a file.
SpecialChar() = Split(" / : * ? " & Chr$(34) & " < > |", " ")
'Find the last row.
With sh
.Activate
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
End With
'Check if the download folder exists.
DownloadFolder = sh.Range("B4")
On Error Resume Next
If Dir(DownloadFolder, vbDirectory) = vbNullString Then
MsgBox "The folder's path is incorrect!", vbCritical, "Folder's Path Error"
sh.Range("B4").Select
Exit Sub
End If
On Error GoTo 0
'Check if there is at least one URL.
If LastRow < 8 Then
MsgBox "You did't enter a single URL!", vbCritical, "No URL Error"
sh.Range("C8").Select
Exit Sub
End If
'Clear the results column.
sh.Range("D8:D" & LastRow).ClearContents
'Add the backslash if doesn't exist.
If Right(DownloadFolder, 1) <> "" Then
DownloadFolder = DownloadFolder & ""
End If
'Counting the number of files that will not be downloaded.
CountErrors = 0
'Save the internet files at the specified folder of your hard disk.
On Error Resume Next
For i = 8 To LastRow
'Find the characters after the last "/" of the URL.
With WorksheetFunction
FilePath = Mid(sh.Cells(i, 3), .Find("*", .Substitute(sh.Cells(i, 3), "/", "*", Len(sh.Cells(i, 3)) - _
Len(.Substitute(sh.Cells(i, 3), "/", "")))) + 1, Len(sh.Cells(i, 3)))
End With
'Check if the file path contains a special/illegal character.
For j = LBound(SpecialChar) To UBound(SpecialChar)
SpecialCharFound = InStr(1, FilePath, SpecialChar(j), vbTextCompare)
'If an illegal character is found substitute it with a "-" character.
If SpecialCharFound > 0 Then
FilePath = WorksheetFunction.Substitute(FilePath, SpecialChar(j), "-")
End If
Next j
'Create the final file path.
FilePath = DownloadFolder & FilePath
'Check if the file path exceeds the maximum allowable characters.
If Len(FilePath) > 255 Then
sh.Cells(i, 4) = "ERROR"
sh.Cells(i, 2) = "ERROR1"
CountErrors = CountErrors + 1
End If
'If the file path is valid, save the file into the selected folder.
If UCase(sh.Cells(i, 4)) <> "ERROR" Then
'Try to download and save the file.
Result = URLDownloadToFile(0, sh.Cells(i, 3), FilePath, 0, 0)
'Check if the file downloaded successfully and exists.
If Result = 0 And Not Dir(FilePath, vbDirectory) = vbNullString Then
'Success!
sh.Cells(i, 4) = "OK"
sh.Cells(i, 2) = Result & "&" & FilePath & "&" & vbDirectory
Else
'Error!
sh.Cells(i, 4) = "ERROR"
sh.Cells(i, 2) = Result & "&" & FilePath & "&" & vbDirectory
CountErrors = CountErrors + 1
End If
End If
Next i
On Error GoTo 0
'Enable the screen.
Application.ScreenUpdating = True
'Inform the user that macro finished successfully or with errors.
If CountErrors = 0 Then
'Success!
If LastRow - 7 = 1 Then
MsgBox "The file was successfully downloaded!", vbInformation, "Done"
Else
MsgBox LastRow - 7 & " files were successfully downloaded!", vbInformation, "Done"
End If
Else
'Error!
If CountErrors = 1 Then
MsgBox "There was an error with one of the files!", vbCritical, "Error"
Else
MsgBox "There was an error with " & CountErrors & " files!", vbCritical, "Error"
End If
End If
End Sub
This code downloads most files just fine, but I ran across issues when trying to download from SPP(Southwest Power Pool)'s API. For Example:
https://marketplace.spp.org/file-api/download/da-lmp-by-location?path=%2F2018%2F11%2FDA-LMP-MONTHLY-SL-201811.csv
This file or any similar file that I try to download from this api is identified and downloaded just fine by any browser or download manager, but URLDownloadToFile reports an error and does not download the file. It downloads files from other sources successfully
My knowledge of coding allowed me to track down the error/return code, which is reported in column B by the following bit of code:
sh.Cells(i, 2) = Result & "&" & FilePath & "&" & vbDirectory
To my understanding, this indicates INET_E_SECURITY_PROBLEM with return code of -2146697202.
Beyond Identifying the error, I am out of my depth.
Assistance in figuring out how to get past this major roadblock would be greatly appreciated.

Create an array of file names in a folder - Excel VBA

I am currently using Application.GetOpenFilename with MultiSelect:=True to allow the user to select one or more files within a folder, then importing the data from all of the files into a worksheet. If multiple files are selected, the data from each file is appended to the data from the previous file until all of the selected files are imported.
I now have an instance where text files are stored in subfolders of a specific folder, with the subfolders created based on order numbers. I am now trying to define the parent folder as a variable, allow the user to input the subfolder name using Application.InputBox, then automatically import the data from all .txt files in the user-specified subfolder. I'm getting hung up with a Run-time error '53', File not found error. I know using the GetOpenFilename approach creates an array of the filenames, and I tried to replicate this by creating an array of the file names but I'm obviously missing something.
I'm basically trying to import all .txt files from something like the following:
C:\AOI_DATA64\SPC_DataLog\IspnDetails\ user defined subfolder \ *.txt
Code that works using Application.GetOpenFilename:
' Define that variables must be defined manually and will never be defined automatically
Option Explicit
' Hold specific variables in memory for use between sub-routines
Public DDThreshold As Variant
Public FileName As String
Public FilePath As String
Public OpenFileName As Variant
Public OrderNum As Variant
Public SaveWorkingDir As String
Public SecondsElapsed As Double
Public StartTime As Double
Public TimeRemaining As Double
Sub Import_DataFile()
' Add an error handler
' On Error GoTo ErrorHandler
' Speed up this sub-routine by turning off screen updating and auto calculating until the end of the sub-routine
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Define variable names and types
Dim DefaultOpenPath As String
Dim SaveWorkingDir As String
Dim OpenFileName As Variant
Dim WholeFile As String
Dim SplitArray
Dim LineNumber As Integer
Dim chkFormat1 As String
Dim i As Long
Dim n1 As Long
Dim n2 As Long
Dim fn As Integer
Dim RawData As String
Dim rngTarget As Range
Dim rngFileList As Range
Dim TargetRow As Long
Dim FileListRow As Long
Dim aLastRow As Long
Dim bLastRow As Long
Dim cLastRow As Long
Dim dLastRow As Long
Dim destCell As Range
' Set the default path to start at when importing a file
'On Error Resume Next
If Len(Dir("C:\AOI_DATA64\SPC_DataLog\IspnDetails", vbDirectory)) = 0 Then
DefaultOpenPath = "C:\"
Else
DefaultOpenPath = "C:\AOI_DATA64\SPC_DataLog\IspnDetails\"
End If
' When opening another file for processing, this section will save the previously opened file directory
'On Error Resume Next
If SaveWorkingDir = CurDir Then
ChDrive SaveWorkingDir
ChDir SaveWorkingDir
Else
ChDrive DefaultOpenPath
ChDir DefaultOpenPath
End If
' Select the source folder and point list file(s) to import into worksheet
'On Error GoTo ErrorHandler
OpenFileName = Application.GetOpenFilename( _
FileFilter:="AOI Inspection Results Data Files (*.txt), *.txt", _
Title:="Select a data file or files to import", _
MultiSelect:=True)
' Cancel the file import if the user exits the file import window or selects the Cancel button
If Not IsArray(OpenFileName) Then
MsgBox "" & vbNewLine & _
" No files were selected." & vbNewLine & _
"" & vbNewLine & _
" Import AOI Inspection Results Data Files was aborted.", vbInformation, "File Import Cancelled"
Exit Sub
End If
' Clear contents and reset formatting of cells in all worksheets
aLastRow = Worksheets("AOI Inspection Summary").Cells(Rows.Count, "B").End(xlDown).Row
bLastRow = Worksheets("Raw Data").Cells(Rows.Count, "A").End(xlDown).Row
cLastRow = Worksheets("Parsed Data").Cells(Rows.Count, "A").End(xlDown).Row
Worksheets("AOI Inspection Summary").Range("E6:L14").ClearContents
If aLastRow > 0 Then
Worksheets("AOI Inspection Summary").Range("B24:L" & aLastRow).ClearContents
Worksheets("AOI Inspection Summary").Range("B24:L" & aLastRow).ClearFormats
End If
If bLastRow > 0 Then
Worksheets("Raw Data").Range("A1:Q" & bLastRow).ClearContents
Worksheets("Raw Data").Range("A1:Q" & bLastRow).ClearFormats
End If
If cLastRow > 0 Then
Worksheets("Parsed Data").Range("A1:Q" & cLastRow).ClearContents
Worksheets("Parsed Data").Range("A1:Q" & cLastRow).ClearFormats
End If
Worksheets("AOI Inspection Summary").Range("E6:L9").NumberFormat = "#" 'Format cells to Text
Worksheets("AOI Inspection Summary").Range("E10:L13").NumberFormat = "#,000" 'Format Cells to Number with commas
Worksheets("AOI Inspection Summary").Range("E14:L14").NumberFormat = "0.00%" 'Format cells to Percent
Worksheets("Raw Data").Columns("A:Z").EntireColumn.ColumnWidth = 8.09
Worksheets("Parsed Data").Columns("A:Z").EntireColumn.ColumnWidth = 8.09
' Update "Defect Density Threshold" to default value unless user entered a new value
If DDThreshold > 0 Then
Worksheets("AOI Inspection Summary").Range("E10").Value = DDThreshold
Else
Worksheets("AOI Inspection Summary").Range("E10").Value = "3,000,000"
End If
' Save the user selected open file directory as the default open file path while the worksheet is open
SaveWorkingDir = CurDir
' Timer Start (calculate the length of time this sub-routine takes to complete after selecting file(s) to import)
StartTime = Timer
' Check selected input file format for YesTech AOI Inspection Results format
Const chkYesTech = "[StartIspn]"
For n1 = LBound(OpenFileName) To UBound(OpenFileName)
fn = FreeFile
Open OpenFileName(n1) For Input As #fn
Application.StatusBar = "Processing ... " & OpenFileName(n1)
WholeFile = Input(LOF(fn), #fn)
SplitArray = Split(WholeFile, vbCrLf)
LineNumber = 1
chkFormat1 = SplitArray(LineNumber - 1)
Close #fn
If InStr(1, chkFormat1, chkYesTech, vbBinaryCompare) > 0 Then
MsgBox OpenFileName(n1) & vbNewLine & " has been verified as a YesTech AOI Inspection Results Data File"
' Import user selected YesTech AOI Inspection Results Data File(s) to "Raw Data" worksheet
Application.DisplayAlerts = False
TargetRow = 0
Set destCell = Worksheets("Raw Data").Range("B1")
For n2 = LBound(OpenFileName) To UBound(OpenFileName)
fn = FreeFile
Open OpenFileName(n2) For Input As #fn
Application.StatusBar = "Processing ... " & OpenFileName(n2)
' Import data from file into Raw Data worksheet
Do While Not EOF(fn)
Line Input #fn, RawData
If Len(Trim(RawData)) > 0 Then
TargetRow = TargetRow + 1
Worksheets("Raw Data").Range("B" & TargetRow) = RawData
End If
Loop
Next n2
Close #fn
Set rngTarget = Worksheets("Raw Data").Range("B1" & ":" & Worksheets("Raw Data").Range("B1").End(xlDown).Address)
With rngTarget
.TextToColumns Destination:=destCell, DataType:=xlDelimited, _
TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=True, Comma:=True, Space:=False, Other:=False, OtherChar:="|", _
FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
End With
Application.DisplayAlerts = True
Else: MsgBox OpenFileName(n1) & vbNewLine & " is not a YesTech AOI Inspection Results Data File."
Exit Sub
End If
Next
' Create a number list (autofill) in Col A to maintain original import sort order
dLastRow = Worksheets("Raw Data").Cells(Rows.Count, "B").End(xlUp).Row
Worksheets("Raw Data").Range("A1:A" & dLastRow).Font.Color = RGB(200, 200, 200)
Worksheets("Raw Data").Range("A1") = "1"
Worksheets("Raw Data").Range("A2") = "2"
Worksheets("Raw Data").Range("A1:A2").AutoFill Destination:=Worksheets("Raw Data").Range("A1:A" & dLastRow), Type:=xlFillDefault
Worksheets("Raw Data").Range("F1:Q" & dLastRow).NumberFormat = "0.0"
' List open file name(s) on spreadsheet for user reference
Worksheets("AOI Inspection Summary").Range("E9").Font.Name = "Calibri"
Worksheets("AOI Inspection Summary").Range("E9").Font.Size = 9
Worksheets("AOI Inspection Summary").Range("E9").Font.Bold = False
Worksheets("AOI Inspection Summary").Range("E9").Font.Color = RGB(0, 0, 255)
FileListRow = 0
Set rngFileList = Worksheets("AOI Inspection Summary").Range("E9")
For i = LBound(OpenFileName) To UBound(OpenFileName)
' Add imported file name hyperlink to imported files in list of imported files
' rngFileList.Offset(FileListRow, 0) = OpenFileName(i)
rngFileList.Hyperlinks.Add Anchor:=rngFileList, _
Address:=OpenFileName(i), _
ScreenTip:="Imported File Number " & FileListRow + 1, _
TextToDisplay:=OpenFileName(i)
Worksheets("AOI Inspection Summary").Range("E7").Value = OpenFileName(i)
FileListRow = FileListRow + 1
Next i
' Auto fit the width of columns for RAW Data
Worksheets("Raw Data").Columns("A:Z").EntireColumn.AutoFit
' Timer Stop (calculate the length of time this sub-routine took to complete)
SecondsElapsed = Round(Timer - StartTime, 2)
' Turn screen updating and auto calculating back on since file processing is now complete
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
' Display a message to report the sub-routine processing time after file selection including the number of data rows that have been imported
MsgBox "AOI Inspection Results processed and imported in " & SecondsElapsed & " seconds" & " ." & vbNewLine & _
" Successfully imported " & (TargetRow) & " rows of data.", vbInformation, "Data Import Results"
' Reset to defaults in the event of a processing error during the sub-routine execution
ErrorHandler:
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
If Err.Number <> 0 Then
' Display a message to user including error code in the event of an error during execution
MsgBox "An error number " & Err.Number & " was encountered!" & vbNewLine & _
"Part or all of this VBA script was not completed.", vbInformation, "Error Message"
End If
Call Create_Report
End Sub
And here's my attempt at defining the parent folder, asking the user for the subfolder name using Application.InputBox, and loading all of the *.txt filenames into an array to be imported:
' Define that variables must be defined manually and will never be defined automatically
Option Explicit
' Hold specific variables in memory for use between sub-routines
Public DDThreshold As Variant
Public FileName As String
Public FilePath As String
Public OpenFileName As Variant
Public OrderNum As Variant
Public SaveWorkingDir As String
Public SecondsElapsed As Double
Public StartTime As Double
Public TimeRemaining As Double
Sub OrderLineNum()
' Add an error handler
'On Error GoTo ErrorHandler
' Speed up sub-routine by turning off screen updating and auto calculating
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Define variable names and data types
Dim DefaultOpenPath As String
Dim SaveWorkingDir As String
Dim OrderNum As Variant
Dim GetFile As String
Dim FileCount As Long
Dim OpenFileName() As String
ReDim OpenFileName(1000)
Dim WholeFile As String
Dim SplitArray
Dim LineNumber As Integer
Dim chkFormat1 As String
Dim i As Long
Dim n1 As Long
Dim n2 As Long
Dim fn As Integer
Dim RawData As String
Dim rngTarget As Range
Dim rngFileList As Range
Dim TargetRow As Long
Dim FileListRow As Long
Dim aLastRow As Long
Dim bLastRow As Long
Dim cLastRow As Long
Dim dLastRow As Long
Dim destCell As Range
' Set the default path to start at when importing a file
' On Error Resume Next
If Len(Dir("C:\AOI_DATA64\SPC_DataLog\IspnDetails", vbDirectory)) = 0 Then
DefaultOpenPath = "C:\"
Else
DefaultOpenPath = "C:\AOI_DATA64\SPC_DataLog\IspnDetails\"
End If
' When opening another file for processing, save the previously opened file directory
' On Error Resume Next
If SaveWorkingDir = CurDir Then
ChDrive SaveWorkingDir
ChDir SaveWorkingDir
Else
ChDrive DefaultOpenPath
ChDir DefaultOpenPath
End If
' Open InputBox to get order-line number from user
OrderNum = Application.InputBox(prompt:= _
"Enter Order-Line Number (e.g. 12345678-9)", _
Title:="Password Required for This Function", _
Default:="", _
Left:=25, _
Top:=25, _
HelpFile:="", _
HelpContextID:="", _
Type:=2)
If OrderNum = "" Then
MsgBox "No Order Number entered. No data will be imported.", vbInformation, "Invalid Order Number"
Exit Sub
ElseIf OrderNum = "0" Then
MsgBox "Order Number cannot be 0. No data will be imported.", vbInformation, "Invalid Order Number"
Exit Sub
ElseIf OrderNum = False Then
MsgBox "User cancelled. No data will be imported.", vbInformation, "User Cancelled"
Exit Sub
End If
' Create an array of filenames found in the Order-Line Number sub-folder
GetFile = Dir$(CurDir & "\" & OrderNum & "\" & "*.txt")
Do While GetFile <> ""
OpenFileName(FileCount) = GetFile
GetFile = Dir$
FileCount = FileCount + 1
Loop
ReDim Preserve OpenFileName(FileCount - 1)
' Save the user selected open file directory as the default open file path while the worksheet is open
SaveWorkingDir = CurDir
' Timer Start (calculate the length of time this sub-routine takes to complete after selecting file(s) to import)
StartTime = Timer
' Cancel the file import if the Order-Line Number subfolder doesn't exist
If Not IsArray(OpenFileName) Then
MsgBox "" & vbNewLine & _
" No files were selected." & vbNewLine & _
"" & vbNewLine & _
" Import AOI Inspection Results Data Files was aborted.", vbInformation, "File Import Cancelled"
Exit Sub
End If
' Clear contents of cells and data worksheets
aLastRow = Worksheets("AOI Inspection Summary").Cells(Rows.Count, "B").End(xlDown).Row
bLastRow = Worksheets("Raw Data").Cells(Rows.Count, "A").End(xlDown).Row
cLastRow = Worksheets("Parsed Data").Cells(Rows.Count, "A").End(xlDown).Row
Worksheets("AOI Inspection Summary").Range("E6:L14").ClearContents
If aLastRow > 0 Then
Worksheets("AOI Inspection Summary").Range("B24:L" & aLastRow).ClearContents
Worksheets("AOI Inspection Summary").Range("B24:L" & aLastRow).ClearFormats
End If
If bLastRow > 0 Then
Worksheets("Raw Data").Range("A1:Q" & bLastRow).ClearContents
Worksheets("Raw Data").Range("A1:Q" & bLastRow).ClearFormats
End If
If cLastRow > 0 Then
Worksheets("Parsed Data").Range("A1:Q" & cLastRow).ClearContents
Worksheets("Parsed Data").Range("A1:Q" & cLastRow).ClearFormats
End If
' Update "Defect Density Threshold" to default value unless user entered a new value
If DDThreshold > 0 Then
Worksheets("AOI Inspection Summary").Range("E10").Value = DDThreshold
Else
Worksheets("AOI Inspection Summary").Range("E10").Value = "3,000,000"
End If
'Check selected input file format for YesTech AOI Inspection Results format
Const chkYesTech = "[StartIspn]"
For n1 = LBound(OpenFileName) To UBound(OpenFileName)
fn = FreeFile
Open OpenFileName(n1) For Input As #fn
Application.StatusBar = "Processing ... " & OpenFileName(n1)
WholeFile = Input(LOF(fn), #fn)
SplitArray = Split(WholeFile, vbCrLf)
LineNumber = 1
chkFormat1 = SplitArray(LineNumber - 1)
Close #fn
If InStr(1, chkFormat1, chkYesTech, vbBinaryCompare) > 0 Then
MsgBox OpenFileName(n1) & vbNewLine & " has been verified as a YesTech AOI Inspection Results Data File"
' Import user selected YesTech AOI Inspection Results Data File(s) to "Raw Data" worksheet
TargetRow = 0
Set destCell = Worksheets("Raw Data").Range("B1")
For n2 = LBound(OpenFileName) To UBound(OpenFileName)
fn = FreeFile
Open OpenFileName(n2) For Input As #fn
Application.StatusBar = "Processing ... " & OpenFileName(n2)
Do While Not EOF(fn)
Line Input #fn, RawData
If Len(Trim(RawData)) > 0 Then
TargetRow = TargetRow + 1
Worksheets("Raw Data").Range("B" & TargetRow) = RawData
End If
Loop
Next n2
Close #fn
Set rngTarget = Worksheets("Raw Data").Range("B1" & ":" & Worksheets("Raw Data").Range("B1").End(xlDown).Address)
With rngTarget
.TextToColumns Destination:=destCell, DataType:=xlDelimited, _
TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=True, Comma:=True, Space:=False, Other:=False, OtherChar:="|", _
FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
End With
Else: MsgBox OpenFileName(n1) & vbNewLine & " is not a YesTech AOI Inspection Results Data File."
Exit Sub
End If
Next
' Create a number list (autofill) in Col A to maintain original import sort order
dLastRow = Worksheets("Raw Data").Cells(Rows.Count, "B").End(xlUp).Row
Worksheets("Raw Data").Range("A1:A" & dLastRow).Font.Color = RGB(200, 200, 200)
Worksheets("Raw Data").Range("A1") = "1"
Worksheets("Raw Data").Range("A2") = "2"
Worksheets("Raw Data").Range("A1:A2").AutoFill Destination:=Worksheets("Raw Data").Range("A1:A" & dLastRow), Type:=xlFillDefault
Worksheets("Raw Data").Range("F1:Q" & dLastRow).NumberFormat = "0.0"
' List open file name(s) on spreadsheet for user reference
Worksheets("AOI Inspection Summary").Range("E9").Font.Name = "Calibri"
Worksheets("AOI Inspection Summary").Range("E9").Font.Size = 9
Worksheets("AOI Inspection Summary").Range("E9").Font.Bold = True
Worksheets("AOI Inspection Summary").Range("E9").Font.Color = RGB(0, 0, 255)
FileListRow = 0
Set rngFileList = Worksheets("AOI Inspection Summary").Range("E9")
For i = LBound(OpenFileName) To UBound(OpenFileName)
Debug.Print OpenFileName(i)
' Add imported file name or hyperlink to imported files in list of imported files
' rngFileList.Offset(FileListRow, 0) = OpenFileName(i)
rngFileList.Offset(FileListRow, 0).Hyperlinks.Add Anchor:=rngFileList.Offset(FileListRow, 0), _
Address:=OpenFileName(i), _
ScreenTip:="Imported File Number " & FileListRow + 1, _
TextToDisplay:=OpenFileName(i)
rngFileList.Offset(FileListRow, 0).Font.Name = "Calibri"
rngFileList.Offset(FileListRow, 0).Font.Size = 9
rngFileList.Offset(FileListRow, 0).Font.Color = RGB(0, 0, 255)
FileListRow = FileListRow + 1
Next i
' Auto fit the width of columns for RAW Data
Worksheets("Raw Data").Columns("A:Z").EntireColumn.AutoFit
' Timer Stop (calculate the length of time this sub-routine took to complete)
SecondsElapsed = Round(Timer - StartTime, 2)
' Turn screen updating and auto calculating back on since file processing is now complete
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
' Display a message to report the sub-routine processing time after file selection including the number of data rows that have been imported
MsgBox "AOI Inspection Results processed and imported in " & SecondsElapsed & " seconds" & " ." & vbNewLine & _
" Successfully imported " & (TargetRow) & " rows of data.", vbInformation, "Data Import Results"
' Reset to defaults in the event of a processing error during the sub-routine execution
ErrorHandler:
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
If Err.Number <> 0 Then
' Display a message to user including error code in the event of an error during execution
MsgBox "An error number " & Err.Number & " was encountered!" & vbNewLine & _
"Part or all of this VBA script was not completed.", vbInformation, "Error Message"
End If
End Sub
Any ideas or suggestions for a better approach would be greatly appreciated.
As mentioned in my comment, there's a lot going on in your post. However, focusing on this
I am now trying to define the parent folder as a variable, allow the user to input the subfolder name using Application.InputBox, then automatically import the data from all .txt files in the user-specified subfolder.
I have a solution - you can create an array that stores each file (both the path and file name), which you should be able to use to get the file names and then do whatever you need:
Sub import_files()
Dim files As String
Dim parentDir As String
parentDir = InputBox("Please input the directory you want to import files from")
If parentDir = "" Then Exit Sub 'If they hit "Cancel" or don't put anything.
' parentDir = GetFolder() 'UNCOMMENT THIS if you want the user to select a folder via "Windows Explorer"
files = LoopThroughFiles(parentDir, "txt")
' Debug.Print (files)
Dim iFiles() As String
iFiles() = Split(files, ",")
Dim i As Long
For i = LBound(iFiles) To UBound(iFiles)
If iFiles(i) <> "" Then
Debug.Print ("File located: " + parentDir + "\" + iFiles(i))
' THIS IS YOUR ARRAY, `iFILES`, SO HERE IS WHERE YOU DO STUFF
End If
Next i
End Sub
Private Function LoopThroughFiles(inputDirectoryToScanForFile, filenameCriteria) As String
'https://stackoverflow.com/a/45749626/4650297
Dim tmpOut As String
Dim StrFile As String
'Debug.Print "in LoopThroughFiles. inputDirectoryToScanForFile: ", inputDirectoryToScanForFile
StrFile = Dir(inputDirectoryToScanForFile & "\*" & filenameCriteria)
Do While Len(StrFile) > 0
' Debug.Print StrFile
tmpOut = tmpOut + "," + StrFile
StrFile = Dir
Loop
LoopThroughFiles = tmpOut
End Function
Function GetFolder() As String
' https://stackoverflow.com/a/26392703/4650297
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Edit: I added a method to have the user select the folder via a more "traditional" Windows Explorer type window, instead of pasting in a path string. Either one should work for you though, let me know any questions.

Download a set of images from Excel with their names using a macros

I want to run a VBScript macro to download a set of images from an URL which can de sorted by the key , (comma). I have to name each image with names given in the secondary column. For example: I have 2 columns and 5 rows. In column "A" I have all the names of the images and in column "B" I have all the URL links which can be sorted by the ,. Now I want to download all the images with their names in column "A" and for the second set of images it should rename column "A" by adding 2 at the end of each row, and then it should start downloading the second set of images. Same should go for the 3rd set or 4th set until the image set ends. Sometimes there might be only one image URL in column "B".
Here is the script which I tried to download but I was not able to sort the images and download it by renaming it again.
Option Explicit
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Dim Ret As Long
'~~> This is where the images will be saved. Change as applicable
Const FolderName As String = "C:\Temp\"
Sub Sample()
Dim ws As Worksheet
Dim LastRow As Long, i As Long
Dim strPath As String
'~~> Name of the sheet which has the list
Set ws = Sheets("Sheet1")
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow '<~~ 2 because row 1 has headers
strPath = FolderName & ws.Range("A" & i).Value & ".jpg"
Ret = URLDownloadToFile(0, ws.Range("B" & i).Value, strPath, 0, 0)
If Ret = 0 Then
ws.Range("C" & i).Value = "File successfully downloaded"
Else
ws.Range("C" & i).Value = "Unable to download the file"
End If
Next i
End Sub
VBScript is not VB, all variables in VBScript are automatically of type Variant and does not directly support API's. It utilizes COM objects instead.
You have to implement a new function that does the same like URLDownloadToFile API call from urlmon.dll.
This should work:
Function URLDownloadToFile(szURL, szFileName, OverWrite)
On Error Resume Next
Dim FSO: Set FSO = WScript.CreateObject("Scripting.FileSystemObject")
Dim ADO_STREAM: Set ADO_STREAM = WScript.CreateObject("ADODB.Stream")
Dim HTTP: Set HTTP = WScript.CreateObject("Microsoft.XMLHTTP")
HTTP.Open "GET", CStr(szURL), False
HTTP.Send
If Err.Number <> 0 Then
WScript.Echo "An error has occured, Not connected to a network" + VbCrLf + "Error " + CStr(Err.Number) + ", " + CStr(Err.Description)
Err.Clear
URLDownloadToFile = CInt(-1)
Exit Function
End If
With ADO_STREAM
.Type = 1
.Open
.Write HTTP.ResponseBody
.SaveToFile szFileName, (CInt(OverWrite) + 1)
End With
If Err.Number <> 0 Then
WScript.Echo "URLDownloadToFile failed, Error " + CStr(Err.Number) + VbCrLf + CStr(Err.Description)
Err.Clear
URLDownloadToFile = CInt(-1)
Exit Function
End If
If (Err.Number = 0) And (FSO.FileExists(szFileName) = True) Then
URLDownloadToFile = CInt(0)
End If
On Error Goto 0
End Function
Usage of this function:
Ret = URLDownloadToFile(ws.Range("B" & i).Value, strPath, 1)
About OverWrite parameter:
Valid values: 0 or 1
1 overwrites existing file and 0 creates a new file if file doesn't exist.
If the file downloaded successfully, above function returns 0 and otherwise it returns -1 (In case any error).
Define following, so you can get the last row in Excel.
'~~> Define xlUp
Const xlUp = -4162
You must create an object referring Excel Application like:
Dim Excel: Set Excel = WScript.CreateObject("Excel.Application")
Use Excel.Sheets, instead of using only Sheets in VB. Example:
Set ws = Excel.Sheets("Sheet1")
IMPORTANT: Change your code as applicable.
Dim Ret
'~~> This is where the images will be saved.
Const FolderName = "E:\TEST\"
Sub Sample()
Dim ws, LastRow, i, strPath
'~~> Name of the sheet which has the list
Set ws = Excel.Sheets("Sheet1")
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow '<~~ 2 because row 1 has headers
strPath = FolderName & ws.Range("A" & i).Value & ".jpg"
Ret = URLDownloadToFile(ws.Range("B" & i).Value, strPath, 1) '<~~ 1 to overwrite existing file
If Ret = 0 Then
ws.Range("C" & i).Value = "File successfully downloaded"
Else
ws.Range("C" & i).Value = "Unable to download the file"
End If
Next
End Sub

Resources