Update VBA code into include Subfolder files (Breaking Excel Links)

[klynch]

Hi There,

I currently have this code to break links on excel files in a selected directory.

I am currently having issues updating this to also look at excels in subfolders.

If someone could assist me with this you will be a lifesaver!

Sub Delete_Bad_Links()
'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
Dim ExternalLinks As Variant
Dim x As Long


'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

'PURPOSE: Breaks all external links that would show up in Excel's "Edit Links" Dialog Box

'Create an Array of all External Links stored in Workbook
ExternalLinks = wb.LinkSources(Type:=xlLinkTypeExcelLinks)

If IsArray(ExternalLinks) Then
'Loop Through each External Link in ActiveWorkbook and Break it
For x = 1 To UBound(ExternalLinks)
wb.BreakLink Name:=ExternalLinks(x), Type:=xlLinkTypeExcelLinks
Next x
End If

'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

Thanks,
Kyle

 

[shknbk2]

Welcome to the forum.

A quick internet search reveals lots of "find all files in subfolders" examples. I took the first one I found and modified it for your code.

Dim ExcelFiles() As String
Dim fCount As Integer

Sub Delete_Bad_Links()
'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
    Dim ExternalLinks As Variant
    Dim x As Long
    Dim i As Integer
    
    '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
    
    fCount = -1
    LoopAllSubFolders myPath
    
    'Loop through each Excel file in folder
    For i = 0 To fCount
        'Set variable equal to opened workbook
        Set wb = Workbooks.Open(filename:=ExcelFiles(i))
        
        'Ensure Workbook has opened before moving on to next line of code
        DoEvents
        
        'PURPOSE: Breaks all external links that would show up in Excel's "Edit Links" Dialog Box
        
        'Create an Array of all External Links stored in Workbook
        ExternalLinks = wb.LinkSources(Type:=xlLinkTypeExcelLinks)
        
        If IsArray(ExternalLinks) Then
        'Loop Through each External Link in ActiveWorkbook and Break it
            For x = 1 To UBound(ExternalLinks)
                wb.BreakLink Name:=ExternalLinks(x), Type:=xlLinkTypeExcelLinks
            Next x
        End If
        
        'Save and Close Workbook
        wb.Close SaveChanges:=True
        
        'Ensure Workbook has closed before moving on to next line of code
        DoEvents
        
    Next i
    '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

Sub LoopAllSubFolders(ByVal folderPath As String)
    Dim filename As String
    Dim fullFilePath As String
    Dim numFolders As Long
    Dim folders() As String
    Dim i As Long
    
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    filename = Dir(folderPath & "*.*", vbDirectory)
    While Len(filename) <> 0
        If Left(filename, 1) <> "." Then
            fullFilePath = folderPath & filename
            If (GetAttr(fullFilePath) And vbDirectory) = vbDirectory Then
                ReDim Preserve folders(0 To numFolders) As String
                folders(numFolders) = fullFilePath
                numFolders = numFolders + 1
            Else
                If Mid(filename, InStrRev(filename, "."), 4) = ".xls" Then
                    fCount = fCount + 1
                    ReDim Preserve ExcelFiles(fCount)
                    ExcelFiles(fCount) = folderPath & filename
                End If
            End If
        End If
        filename = Dir()
    Wend
    
    For i = 0 To numFolders - 1
        LoopAllSubFolders folders(i)
    Next i
End Sub

 

[shknbk2]

Updated code to make the LoopAllSubfolders more generic and to remove global variables.

Sub Delete_Bad_Links()
'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
    Dim ExternalLinks As Variant
    Dim x As Long
    Dim i As Integer
    Dim ExcelFiles() As String
    
    '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
    
    If Not LoopAllSubFolders(ExcelFiles, myPath, "*.xls") Then
        MsgBox "No files found."
        Exit Sub
    End If
    
    'Loop through each Excel file in folder
    For i = 0 To UBound(ExcelFiles)
        'Set variable equal to opened workbook
        Set wb = Workbooks.Open(filename:=ExcelFiles(i))
        
        'Ensure Workbook has opened before moving on to next line of code
        DoEvents
        
        'PURPOSE: Breaks all external links that would show up in Excel's "Edit Links" Dialog Box
        
        'Create an Array of all External Links stored in Workbook
        ExternalLinks = wb.LinkSources(Type:=xlLinkTypeExcelLinks)
        
        If IsArray(ExternalLinks) Then
        'Loop Through each External Link in ActiveWorkbook and Break it
            For x = 1 To UBound(ExternalLinks)
                wb.BreakLink Name:=ExternalLinks(x), Type:=xlLinkTypeExcelLinks
            Next x
        End If
        
        'Save and Close Workbook
        wb.Close SaveChanges:=True
        
        'Ensure Workbook has closed before moving on to next line of code
        DoEvents
        
    Next i
    '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

Function LoopAllSubFolders(ByRef FoundFiles() As String, _
    ByVal folderPath As String, _
    Optional fileFilter As String = "*", _
    Optional fCount As Integer = -1, _
    Optional firstRun As Boolean = True) As Boolean
    
    Dim filename As String
    Dim fullFilePath As String
    Dim numFolders As Long
    Dim folders() As String
    Dim i As Long
    Dim fileExt As String
    
    If fileFilter = "" Then
        If MsgBox("File filter cannot be a null string." & vbCrLf & vbCrLf & _
          "Do you want to find all files (*.*)?", vbYesNo, "File Filter") = vbYes Then
            fileFilter = "*.*"
        Else
            Exit Function
        End If
    End If
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    filename = Dir(folderPath & "*.*", vbDirectory)
    While Len(filename) <> 0
        If Left(filename, 1) <> "." Then
            fullFilePath = folderPath & filename
            If (GetAttr(fullFilePath) And vbDirectory) = vbDirectory Then
                ReDim Preserve folders(0 To numFolders) As String
                folders(numFolders) = fullFilePath
                numFolders = numFolders + 1
            ElseIf filename Like fileFilter Then
                fCount = fCount + 1
                ReDim Preserve FoundFiles(fCount)
                FoundFiles(fCount) = folderPath & filename
            End If
        End If
        filename = Dir()
    Wend
    
    For i = 0 To numFolders - 1
        LoopAllSubFolders FoundFiles, folders(i), fileFilter, fCount, False
    Next i
    If fCount > -1 Then LoopAllSubFolders = True
End Function

 

[klynch]

Thank you so much! I did try googling a few options however kept falling into issues with the subfolder loop