Word will no longer open through excel VBA - vba

Set up a macro to open word documents through excel. It's been working fine, but after copying the code from the test environment into another file it's refusing to open word on every machine I test it on. Every other part of the macro is working fine, but for some reason word will no longer open via macro.
I've attached the code, but any help would be appreciated. It was working earlier today, and because of this i'm having trouble identifying the problem.
Public Function Method2(ByVal rngl As Range, ByVal strSearch As Variant, ByVal sPath As String)
Dim filePath As String
Dim directory As String
Dim fileName As String
Dim myPath As String
Dim myFile As File
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim myExtension As String
Dim mySubFolder As Folder
Dim mySubFolder2 As Folder
Dim objWord
Dim objDoc
Dim rngRange
Dim rng1 As Range
Set myFolder = FSO.GetFolder(sPath)
directory = "S:\File Recipes\"
fileName = "Yaroze_Test"
myExtension = "*.docx*"
Set rng1 = Range("A:A").find(strSearch, , xlValues, xlWhole)
If strSearch = "" Then
MsgBox "Please Enter a Product Code!"
Exit Function
End If
If Not rng1 Is Nothing Then
MsgBox "Product Codes Found!"
For Each mySubFolder In myFolder.SubFolders
For Each mySubFolder2 In mySubFolder.SubFolders
For Each myFile In mySubFolder.Files
If InStr(myFile, strSearch) > 0 Then
fileName = Dir(myPath & myExtension)
MsgBox (myFile.Name)
Do While fileName <> ""
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
ChDrive ("S")
ChDir ("S:\File Recipes\")
filePath = myFile.Path
MsgBox directory
objWord.Documents.Open fileName:=filePath
DoEvents
fileName = Dir
Loop
MsgBox "Task Complete!"
End If
Next
For Each myFile In mySubFolder2.Files
If InStr(myFile, strSearch) > 0 Then
fileName = Dir(myPath & myExtension)
' MsgBox (myFile.Name)
Do While fileName <> ""
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
ChDrive ("S")
ChDir ("S:\File Recipes\")
filePath = myFile.Path
' MsgBox directory
objWord.Documents.Open fileName:=filePath
DoEvents
fileName = Dir
Loop
MsgBox "Task Complete!"
End If
Next
Next
Next
Else
MsgBox "Product Codes Not Found!"
End If
' Set rngRange = _
objWord.Range(objWord.Paragraphs(1).Start, objWord.Paragraphs(1).End - 1)
' rngRange.InsertAfter _
"This is now the last sentence in paragraph one."
I've attempted to test the Macro on other computers to see if it was just the copy of word I was using, and I've tested writing new Macros to open word. They worked initially but other macros are now no longer working. I've tried disabling office from references in VBA and testing with that, and I've made sure it's not an issue with instances of word being left open.

Related

Encountering a problem in my Do while loop

New to VBA and initially my problem was to copy text in CSV file into string and then ultimately to a master workbook. I used the below code which works perfectly:
Sub Compiler()
Dim handle As Integer
Dim wbDst As Workbook
Dim wsDst As Worksheet
Dim lLastRow As Long
Dim MyPath As String
Dim strFilename As String
handle = FreeFile
Set wbDst = ThisWorkbook
Set wsDst = wbDst.Worksheets("First Sheet")
lLastRow = wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row + 1
Sheets("First Sheet").Columns(1).NumberFormat = "#"
Sheets("First Sheet").Columns(2).NumberFormat = "#"
Sheets("First Sheet").Columns(3).NumberFormat = "#"
MyPath = "W:\Test Folder\"
strFilename = Dir(MyPath, vbNormal)
Do While strFilename <> ""
Dim buffer As String
Open MyPath & strFilename For Input As #handle
buffer = Input(LOF(handle), handle) '<-- reads the entire contents of the file to "buffer"
Close #handle
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText buffer
.PutInClipboard
End With
wsDst.Paste wsDst.Range("A" & lLastRow)
'Application.CutCopyMode = False
strFilename = Dir()
Loop
End Sub
However, for some reason, it only copy pastes some of the files and not others (or maybe it overwrites it?, point is some of the files are not copied in). Not sure why this is the case? Is it because there are some blank cells in files? To rectify this, i replaced all blank cells with 0 - didn't work. Is it because of different copy paste area? Don't know how to rectify that if this is the case
So after long investigation, i found out an impractical approach where if you paste in files that you need to copy one by one, It does the trick but it is inefficient. So just for a temp solution, i did the following where vba code copies in a file from a temp folder to the source folder, does its job of copy pasting to the master work book and then deletes the file that was copied in. For some reason, the code stops at the first even though it's a Do while loop. Not sure what's the problem here and what is most efficient approach here?
Sub ISINCompiler()
'Declare Variables
Dim FSO
Dim MyPath As String
Dim strFilename As String
Dim sFile As String
Dim sSFolder As String
Dim sDFolder As String
Application.DisplayAlerts = False
MyPath = "C:\Users\Tomhardy\Desktop\ISIN-Compiler Temp\"
strFilename = Dir(MyPath, vbNormal)
'This is Your File Name which you want to Copy
'Change to match the destination folder path
sDFolder = "W:\Test Folder\"
'Create Object
Set FSO = CreateObject("Scripting.FileSystemObject")
'Checking If File Is Located in the Source Folder
Do While strFilename <> ""
If Not FSO.FileExists(MyPath & strFilename) Then
MsgBox "Specified File Not Found", vbInformation, "Not Found"
'Copying If the Same File is Not Located in the Destination Folder
ElseIf Not FSO.FileExists(sDFolder & strFilename) Then
FSO.CopyFile (MyPath & strFilename), sDFolder, True
ISINCompilerx2 '<-Copying and pasting in text
DeleteExample1 '<-Deleting the file after it has been copied in
Else
MsgBox "Specified File Already Exists In The Destination Folder",
vbExclamation, "File Already Exists"
End If
strFilename = Dir()
Loop
End Sub
Private Sub ISINCompilerx2()
Dim handle As Integer
Dim wbDst As Workbook
Dim wsDst As Worksheet
Dim lLastRow As Long
Dim someotherpath As String
Dim somestrFilename As String
handle = FreeFile
Set wbDst = ThisWorkbook
Set wsDst = wbDst.Worksheets("First Sheet")
lLastRow = wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row + 1
Sheets("First Sheet").Columns(1).NumberFormat = "#"
Sheets("First Sheet").Columns(2).NumberFormat = "#"
Sheets("First Sheet").Columns(3).NumberFormat = "#"
someotherpath = "W:\Test Folder\"
somestrFilename = Dir(someotherpath, vbNormal)
Do While somestrFilename <> ""
Dim buffer As String
Open someotherpath & somestrFilename For Input As #handle
buffer = Input(LOF(handle), handle) '<-- reads the entire
contents of the file to "buffer"
Close #handle
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText buffer
.PutInClipboard
End With
wsDst.Paste wsDst.Range("A" & lLastRow)
Application.CutCopyMode = False
somestrFilename = Dir()
Loop
End Sub
Private Sub DeleteExample1()
On Error Resume Next
Kill "W:\Test Folder\*.*"
On Error GoTo 0
End Sub
new Code:
Sub ISINCompiler()
'Declare Variables
Dim FSO As Object
Dim MyPath As String
Dim strFilename As String
Dim f As Object
Dim sDFolder As String
Application.DisplayAlerts = False
MyPath = "C:\Users\Tomhardy\Desktop\ISIN-Compiler Temp\"
strFilename = Dir(MyPath, vbNormal)
'This is Your File Name which you want to Copy
'Change to match the destination folder path
sDFolder = "W:\Destination folder\"
' Create Object
Set FSO = CreateObject("Scripting.FileSystemObject")
'Checking If File Is Located in the Source Folder
For Each f In FSO.GetFolder(MyPath).Files
If Not FSO.FileExists(MyPath & strFilename) Then
MsgBox "Specified File Not Found", vbInformation, "Not Found"
'Copying If the Same File is Not Located in the Destination Folder
ElseIf Not FSO.FileExists(sDFolder & strFilename) Then
FSO.CopyFile (MyPath & strFilename), sDFolder, True
'ISINCompilerx2
'DeleteExample1
MsgBox "Specified File Copied Successfully", vbInformation, "Done!"
Else
MsgBox "Specified File Already Exists In The Destination Folder",
vbExclamation, "File Already Exists"
End If
Next f
Set f = Nothing
Set FSO = Nothing
End Sub
You can simplify your code;
Dim Filename As String
Dim lLastRow As Long
Dim wsDst As Worksheet
Set wsDst = ThisWorkbook.Worksheets("First Sheet")
Filename = Dir("W:\Test Folder\*.csv")
Do While Filename <> ""
Set wbSrce = Workbooks.Open(Filename)
lLastRow = wsDst.UsedRange.Rows.Count + 1
wbSrce.Sheets(1).UsedRange.Copy wsDst.Range("A" & lLastRow)
wbSrce.Close savechanges:=False
Filename = Dir
Loop
So i found out that Dir was the problem so i just removed dir in my main macro
Option Explicit
Public wbDst As Workbook
Public wsDst As Worksheet
Sub ISINCompiler()
'Declare Variables
Set wbDst = ThisWorkbook
Set wsDst = wbDst.Worksheets("First Sheet")
Dim i As Long
Dim myFSO As FileSystemObject
Dim xFolder As Scripting.Folder
Dim FSO As Object
Dim f
Dim MyPath As String
Dim sDFolder As String
Application.DisplayAlerts = False
sDFolder = "W:\Destination\"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set myFSO = New FileSystemObject
Set xFolder = myFSO.GetFolder("C:\Source")
'Checking If File Is Located in the Source Folder
For Each f In xFolder.Files
f.Copy sDFolder & f.Name
MsgBox "Specified File Copied Successfully", vbInformation, "Done!"
ISINCompilerx2
DeleteExample1
Next f
End Sub
Private Sub ISINCompilerx2()
Dim handle As Integer
Dim lLastRow As Long
Dim somePath As String
Dim someFilename As String
handle = FreeFile
lLastRow = wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row + 1
Sheets("First Sheet").Columns(1).NumberFormat = "#"
Sheets("First Sheet").Columns(2).NumberFormat = "#"
Sheets("First Sheet").Columns(3).NumberFormat = "#"
somePath = "W:\Destination\"
someFilename = Dir(somePath, vbNormal)
Dim buffer As String
Open somePath & someFilename For Input As #handle
buffer = Input(LOF(handle), handle) '<-- reads the entire contents of
the file to "buffer"
Close #handle
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText buffer
.PutInClipboard
End With
wsDst.Paste wsDst.Range("A" & lLastRow)
Application.CutCopyMode = False
End Sub
Private Sub DeleteExample1()
'You can use this to delete all the files in the folder Test
On Error Resume Next
Kill "W:\Destination\*.*"
On Error GoTo 0
End Sub

VBA to find word documents and specified words in content and then list in excel

I have multiple word documents in a folder.
What I really want is to list the document names and check whether these docs incude some specified words.
I create two word documents for example to explain.
There are two documents, Doc A and Doc B, in a folder.
I want to list the file name Doc A and Doc B in the excel column A.
After listing the doc name in column A, I want to check whether specified words "classification" and "Statistics" are in the docs.
If these specified words in the document, it will mark in the excel. Please see below picture for the result I want.
I provide the code in the following:
Option Explicit
Private xRow As Long
Sub Get_MAIN_File_Names()
Dim fso As FileSystemObject
Dim xDirect As String
Dim xRootFolder As Folder
Dim DrawingNumb As String
Dim RevNumb As String
Dim rootFolderStr As String
Set fso = New FileSystemObject
xRow = 0
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select Main File"
.Show
'PROCESS ROOT FOLDER
If .SelectedItems.Count <> 0 Then
xDirect = .SelectedItems(1) & "\"
Set xRootFolder = fso.GetFolder(xDirect)
ProcessFolder fso, xRootFolder
End If
End With
End Sub
Private Sub ProcessFolder(fso As FileSystemObject, xFolder As Folder)
Dim xFiles As Files
Dim xFile As File
Dim xSubFolders As Folders
Dim xSubFolder As Folder
Dim xFileName As String
Dim objWordApplication As New Word.Application
Dim objWordDocument As Word.Document
Dim strFile As String
strFile = Dir(xFolder & "*.doc", vbNormal)
While strFile <> ""
With objWordApplication
Set objWordDocument = .Documents.Open(FileName:=xFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
Set xFiles = xFolder.Files
'Adding Column names
Cells(1, "A").Value = "Document Name"
Cells(1, "B").Value = "classification"
Cells(1, "C").Value = "Statistics"
'LOOPS THROUGH EACH FILE NAME IN FOLDER
For Each xFile In xFiles
'EXTRACT INFORMATION FROM FILE NAME, this part may not add
xFileName = xFile.Name
Set Docs = objWordDocument.Content
With Docs.Find
.ClearFormatting
.Text = "classification"
Wrap:=wdFindContinue
End With
With Docs.Find
.ClearFormatting
.Text = "Statistics"
Wrap:=wdFindContinue
End With
'INSERT INFO INTO EXCEL
ActiveCell.Offset(xRow, 0) = xFileName
'Below needs to add.
ActiveCell.Offset(xRow, 1) =
ActiveCell.Offset(xRow, 2) =
'Above needs to add.
xRow = xRow + 1
With objWordDocument
.Close
End With
Next xFile
Set xSubFolders = xFolder.SubFolders
For Each xSubFolder In xSubFolders
ProcessFolder fso, xSubFolder
Next xSubFolder
End Sub
Based on above code, it fails.
I think the problem is With Docs.Find.....; however, I'm not really sure about it.
Moreover, I do not know how to do this part.
'Below needs to add.
ActiveCell.Offset(xRow, 1) =
ActiveCell.Offset(xRow, 2) =
'Above needs to add.
Can any one help me edit the code?
Maybe this code will help you out, it does:
Assume you got a activesheet setup with the three headers there
Loop through .docx files in specified folder
Checks wordrange for specified tekst
Returns true or false and puts found or not found in appropriate cell
Sub LoopWordDocs()
Dim FLDR As String
Dim wDoc As Word.Document
Dim wRNG As Word.Range
Dim LR As Long, COL As Long
Dim WS As String
Dim wAPP As Word.Application
Dim WordWasNotRunning As Boolean
On Error Resume Next
Set wAPP = GetObject(, "Word.Application")
If Err Then
Set wAPP = New Word.Application
WordWasNotRunning = True
End If
On Error GoTo Err_Handler
WS = ThisWorkbook.ActiveSheet.Name
FLDR = "U:\Test\" 'Change directory accordingly
aDoc = Dir(FLDR & "*.docx") 'Change docx to .doc if you need
Do While aDoc <> ""
Set wDoc = Documents.Open(Filename:=FLDR & aDoc)
LR = Sheets(WS).Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets(WS).Cells(LR, 1) = aDoc
Set wRNG = wDoc.Range
For COL = 2 To 3 'It will loop through B1 and C1 to check if present in text
With wRNG.Find
.Text = Sheets(WS).Cells(1, COL).Text
.MatchCase = False
.MatchWholeWord = True
If wRNG.Find.Execute = True Then
Sheets(WS).Cells(LR, COL) = "V" 'Change V to your liking
Else
Sheets(WS).Cells(LR, COL) = "X" 'Change X to your liking
End If
End With
Next COL
wDoc.Close SaveChanges:=True
aDoc = Dir
Loop
Exit Sub
Err_Handler:
MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " & Err.Number
If WordWasNotRunning Then
wAPP.Quit
End If
End Sub
Note: You'll have to turn on Microsoft Word 14.0 Object Library for this to work

Find Windows subfolders with specified name

I want to loop through a folder (G:/Proj) and find any subfolders named "SUMMARY LOG" and then print the Excel files, usually just one, within each of those folders.
This is the main folder (Proj) with all of the project folders within it
This is a screenshot of just one of the files I want to print out.
Each project has a SUMMARY LOG folder.
Here is the VBA code. It loops through every sub folder and prints out every Excel file in those folders not just the "SUMMARY LOG".
Sub LoopFolders()
Dim strFolder As String
Dim strSubFolder As String
Dim strFile As String
Dim colSubFolders As New Collection
Dim varItem As Variant
Dim wbk As Workbook
' Parent folder including trailing backslash
strFolder = "G:/Proj/"
' Loop through the subfolders and fill Collection object
strSubFolder = Dir(strFolder & "*", vbDirectory)
Do While Not strSubFolder = ""
Select Case strSubFolder
Case ".", ".."
' Current folder or parent folder - ignore
Case Else
' Add to collection
colSubFolders.Add Item:=strSubFolder, Key:=strSubFolder
End Select
' On to the next one
strSubFolder = Dir
Loop
' Loop through the collection
For Each varItem In colSubFolders
' Loop through Excel workbooks in subfolder
strFile = Dir(strFolder & varItem & "\*.xls*")
Do While strFile <> ""
' Open workbook
Set wbk = Workbooks.Open(Filename:=strFolder & _
varItem & "\" & strFile, AddToMRU:=False)
' Do something with the workbook
ActiveSheet.PrintOut
' Close it
wbk.Close SaveChanges:=False
strFile = Dir
Loop
Next varItem
End Sub
This is how I changed your code (please note that you should set your "objects" to nothing at the end of your code).
Note that I just used a simple "If" statement with the "InStr" function to try and catch the buzzwords associated with your excel workbooks. Here is what my simulated folder looked like:
Simulated Folder with File Names
Sub LoopFolders()
Dim strFolder As String
Dim strSubFolder As String
Dim strFile As String
Dim colSubFolders As New Collection
Dim varItem As Variant
Dim wbk As Workbook
' Parent folder including trailing backslash
strFolder = "C:\Users\anm2mip\Desktop\Exp\"
' Loop through the subfolders and fill Collection object
strSubFolder = Dir(strFolder & "*", vbDirectory)
Do While Not strSubFolder = ""
Select Case strSubFolder
Case ".", ".."
' Current folder or parent folder - ignore
Case Else
' Add to collection
colSubFolders.Add Item:=strSubFolder, Key:=strSubFolder
End Select
' On to the next one
strSubFolder = Dir
Loop
' Loop through the collection
For Each varItem In colSubFolders
' Loop through Excel workbooks in subfolder
strFile = Dir(strFolder & varItem & "\*.xls*") 'never mind the .xlsx, I forgot that the * symbol is wildcard.
Do While strFile <> ""
If InStr(strFile, "Summary") And InStr(strFile, "Log") Then
' Open workbook
Set wbk = Workbooks.Open(FileName:=strFolder & _
varItem & "\" & strFile, AddToMRU:=False)
' Do something with the workbook
MsgBox strFile
' ActiveSheet.PrintOut
' Close it
wbk.Close SaveChanges:=False
End If
strFile = Dir
Loop
Next varItem
Set colSubFolders = Nothing
Set varItem = Nothing
Set wbk = Nothing
End Sub
UPDATE
Test Folder Structure
Note that I threw a couple different excel file types and a word document in there as well, and my code below filters out all except the excel file types that I've specified.
I used this answer as a reference: Recursive drill down into folders example. Thank you user #Cor_Blimey for the easy-to-use post.
Sub LoopFolders()
Dim fso, oFolder, oSubfolder, oFile, queue As Collection
Dim colFiles As New Collection
Dim wbk As Workbook
Set fso = CreateObject("Scripting.FileSystemObject")
Set queue = New Collection
queue.Add fso.GetFolder("C:\Users\anm2mip\Desktop\Exp\")
' Parent folder including trailing backslash
'strFolder = "C:\Users\anm2mip\Desktop\Exp\"
Do While queue.Count > 0
Set oFolder = queue(1)
queue.Remove 1 'dequeue
For Each oSubfolder In oFolder.SubFolders
queue.Add oSubfolder
Next oSubfolder
'Filter subfolders here
If InStr(oFolder.Name, "Summary") And InStr(oFolder.Name, "Log") Then
For Each oFile In oFolder.Files
'You can filter files here with an if...then statement
If oFile.Type = "Microsoft Excel Worksheet" Or _
oFile.Type = "Microsoft Excel 97-2003 Worksheet" Or _
oFile.Type = "Microsoft Excel Macro-Enabled Worksheet" Then
colFiles.Add Item:=oFile, Key:=oFile.Name
Next oFile
End If
Loop
MsgBox "Number of files held in Summary Log folders is: " & colFiles.Count
For Each oFile In colFiles
Set wbk = Workbooks.Open(FileName:=oFile.Path, AddtoMRU:=False)
MsgBox oFile.Name
'Do your printing operation here.
wbk.Close SaveChanges:=False
Next oFile
Set fso = Nothing
Set oFolder = Nothing
Set oSubfolder = Nothing
Set oFile = Nothing
Set queue = Nothing
Set wbk = Nothing
End Sub

Need to modify my VBA code to include subfolders as well

I have created a VBA code that loops through all excel workbooks in a given folder , opens then, refreshes the sheet, pauses for 10 seconds, closes and saves and moves on to the next. The issue I am facing is that it wont do it for the excel workbooks in the subfolder, Please can someone assist.
The code is as per below:
Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Change First Worksheet's Background Fill Blue
Application.Calculate
ActiveWorkbook.RefreshAll
Application.Wait (Now + TimeValue("0:00:10"))
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Its probably an old question indeed, but still, I enjoyed writing it somehow. And in my solution, you get some nice printing in the console. Here you go:
Option Explicit
Function GetFiles(ByVal Folder As String) As Collection
Dim strFile As String
Set GetFiles = New Collection
strFile = Dir(Folder & "\*")
Do While strFile <> ""
GetFiles.Add strFile
strFile = Dir
Loop
End Function
Function GetFolders(ByVal Folder As String) As Collection
Dim strFile As String
Set GetFolders = New Collection
strFile = Dir(Folder & "\*", vbDirectory)
Do While strFile <> ""
If GetAttr(Folder & "\" & strFile) And vbDirectory Then GetFolders.Add strFile
strFile = Dir
Loop
End Function
Sub LoopThroughSubfoldersAsWell()
Dim colFoFi As Collection
Dim varEl01 As Variant
Dim varEl02 As Variant
Dim varEl03 As Variant
Dim strLine As String: strLine = "--------------------------"
Dim strAddress As String: strAddress = "C:\Users\UserName\Desktop\Testing01\"
Debug.Print strAddress
Set colFoFi = GetFiles(strAddress)
For Each varEl01 In colFoFi
Debug.Print varEl01
Next varEl01
Debug.Print strLine
Set colFoFi = GetFolders(strAddress)
For Each varEl01 In colFoFi
If Len(varEl01) > 2 Then 'to avoid some hidden stuff
Set varEl02 = GetFiles(strAddress & varEl01)
Debug.Print (strAddress & varEl01)
For Each varEl03 In varEl02
Debug.Print varEl03
Next varEl03
Debug.Print strLine
End If
Next varEl01
End Sub

Combining macros in Excel

I'm trying to combine/nest 3 different functions in Excel VBE: open, loop, and click. I have them written out separately, but am unsure of how to combine them. I've tried the "call macro" function but got a compile error returned to me.
The goal is to open a bunch of files within a certain folder and click on the URL in all of them (the URL will not always be the same, so I need a click function that targets any unknown URL within a sheet).
Open macro:
Sub openMyfile()
Dim Source As String
Dim StrFile As String
Source = "/users/kmogilevsky/Desktop/IC_new/"
StrFile = Dir("/users/kmogilevsky/Desktop/IC_new/")
Do While Len(StrFile) > 0
Workbooks.Open Filename:=Source & StrFile
StrFile = Dir("/users/kmogilevsky/Desktop/IC_new/")
Loop
End Sub
Loop macro:
Sub LoopThroughFiles()
Dim MyObj As Object, MySource As Object, file As Variant
Set MySource = MyObj.GetFolder("/users/kmogilevsky/Desktop/IC_new/")
For Each file In MySource.Files
If InStr(file.Name, "test") > 0 Then
End If
Next file
End Sub
Click macro (this needs some work):
Private Sub CommandButton1_Click()
Call NewSub
End Sub
Sub ReadWorkbooksInCurrentFolder()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim MyPath As String
Dim strFilename As String
'Stop annoying popups while macro is running
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
'When working with many open workbooks its good to explicitly reference all workbooks, makes sure your code works and easier to read, understand and remember which workbook is which.
Set wbDst = ThisWorkbook
srcSheetName = "Data"
dstSheetName = "Results"
'I want to loop through all .xlsx files in the folder
MyPath = ThisWorkbook.Path
strFilename = Dir(MyPath & "\*.xlsx", vbNormal)
If Len(strFilename) = 0 Then
MsgBox "No workbooks found ending in .xlsx in current folder"
Exit Sub
End If
Do Until strFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
Call CollectData(wbDst, wbSrc, dstSheetName, srcSheetName)
wbSrc.Close
strFilename = Dir()
Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Sub CollectData(ByRef wbDst as Workbook, ByRef wbSrc as Workbook, dstSheetName as String, srcSheetName as String)
'Copy cell A1 contents in source workbook to destination workbook cell A1
wbDst.Sheets(dstSheetName).Range("A1") = wbSrc.Sheets(srcSheetName).Range("A1")
End Sub
Please edit the subroutine CollectData() so that it suits your needs, i.e. performs the click / url open. (I am not familiar with opening urls from excel, but I loop through workbooks often)
This code will open all Excel files in the IC_New folder on the desktop.
It will then look at each sheet and follow any hyperlinks that are on the sheet.
Sub Open_ClickHyperlinks()
Dim sPath As String
Dim vFiles As Variant
Dim vFile As Variant
Dim wrkBk As Workbook
Dim wrkSht As Worksheet
Dim HLink As Hyperlink
sPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator & _
"IC_New" & Application.PathSeparator
'Return all files that have an extension starting with xls.
vFiles = EnumerateFiles(sPath, "xls*")
'Loop through each file.
For Each vFile In vFiles
'Open the file
Set wrkBk = Workbooks.Open(Filename:=vFile, UpdateLinks:=False)
With wrkBk
'Loop through each worksheet in the file.
For Each wrkSht In .Worksheets
'Loop through each hyperlink on the worksheet.
For Each HLink In wrkSht.Hyperlinks
HLink.Follow
Next HLink
Next wrkSht
.Close SaveChanges:=False
End With
Next vFile
End Sub
'Get all files in the specified folder, default to include all subfolders as well.
Public Function EnumerateFiles(sDirectory As String, _
Optional sFileSpec As String = "*", _
Optional InclSubFolders As Boolean = True) As Variant
EnumerateFiles = Filter(Split(CreateObject("WScript.Shell").Exec _
("CMD /C DIR """ & sDirectory & "*." & sFileSpec & """ " & _
IIf(InclSubFolders, "/S ", "") & "/B /A:-D").StdOut.ReadAll, vbCrLf), ".")
End Function