Open-Save As File Loop

[kyddrivers]

I am looking to create a loop to execute on a specific set of files inside a folder that contains 30+ files.

Dim wb As Workbook
strFileName = ThisWorkbook.FullName

Workbooks.Open Filename:= Folder & "File Name 1.xlsm"

Set wb = Application.ActiveWorkbook


  If Not IsEmpty(wb.LinkSources(xlExcelLinks)) Then
    For Each link In wb.LinkSources(xlExcelLinks)
        wb.BreakLink link, xlLinkTypeExcelLinks
    Next link
  End If

ActiveWorkbook.SaveAs Filename:= Folder2 & strFileName

ActiveWorkbook.Close

Repeat for File 2

Repeat for File 3

Any help would be greatly appreciated.

Thanks!!

 

[Domenic]

Try...

Option Explicit

Sub BreakLinksInFiles()


    Dim sourceFolder As String
    Dim destFolder As String
    Dim currentFile As String
    Dim currentWorkbook As Workbook
    Dim linkSources As Variant
    Dim currentLink As Variant
    Dim fileCount As Long
    
    'set the path to the source folder (change accordingly)
    sourceFolder = "C:\Users\Domenic\Desktop\Folder1\"
    
    'ensure path to the source folder ends with a backslash (\)
    If Right(sourceFolder, 1) <> "\" Then
        sourceFolder = sourceFolder & "\"
    End If
    
    'make sure source folder exists
    If Len(Dir(sourceFolder, vbDirectory)) = 0 Then
        MsgBox "'" & sourceFolder & "' not found!", vbExclamation
        Exit Sub
    End If
    
    'set the path to the destination folder (change accordingly)
    destFolder = "C:\Users\Domenic\Desktop\Folder2\"
    
    'ensure the path to the destination folder ends with a backslash (\)
    If Right(destFolder, 1) <> "\" Then
        destFolder = destFolder & "\"
    End If
    
    'make sure destination folder exists
    If Len(Dir(destFolder, vbDirectory)) = 0 Then
        MsgBox "'" & destFolder & "' not found!", vbExclamation
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    'get the first .xlsm file from the source folder
    currentFile = Dir(sourceFolder & "*.xlsm", vbNormal)
    
    fileCount = 0
    Do While Len(currentFile) > 0 'file exists
        'increment file count
        fileCount = fileCount + 1
        'open the current file and update the links
        Set currentWorkbook = Workbooks.Open(Filename:=sourceFolder & currentFile, UpdateLinks:=True)
        'get the links from the current workbook
        linkSources = currentWorkbook.linkSources(xlExcelLinks)
        'break the links in the current workbook, if they exist
        If Not IsEmpty(linkSources) Then
            For Each currentLink In linkSources
                currentWorkbook.BreakLink currentLink, xlLinkTypeExcelLinks
            Next currentLink
        End If
        With currentWorkbook
            'save the current workbook to the destination folder, overwrite if one with the same name already exists
            Application.DisplayAlerts = False
            .SaveAs Filename:=destFolder & currentWorkbook.Name
            Application.DisplayAlerts = True
            'close the current workbook
            .Close savechanges:=False
        End With
        'get the next .xlsm file from the source folder
        currentFile = Dir
    Loop
    
    'clear from memory
    Set currentWorkbook = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "Processed files: " & fileCount, vbInformation
    
End Sub

Hope this helps!

 

[kyddrivers]

How am I specifing the 3 files I need to work on out of the 30+ in the folder??

 

[Domenic]

Sorry, it looks like I misunderstood. I thought you wanted to loop through each file within the folder. If you only want to work on 3 files, the code would look a little different. I'll look at this again when I get a chance, if no one else jumps in with a solution.

 

[Domenic]

Try...

Option Explicit

Sub BreakLinksInFiles()


    Dim sourceFolder As String
    Dim destFolder As String
    Dim pathAndFilename As String
    Dim targetFiles As Variant
    Dim currentFile As Variant
    Dim currentWorkbook As Workbook
    Dim linkSources As Variant
    Dim currentLink As Variant
    Dim fileCount As Long
    
    'set the path to the source folder (change accordingly)
    sourceFolder = "C:\Users\Domenic\Desktop\Folder1\"
    
    'ensure path to the source folder ends with a backslash (\)
    If Right(sourceFolder, 1) <> "\" Then
        sourceFolder = sourceFolder & "\"
    End If
    
    'make sure source folder exists
    If Len(Dir(sourceFolder, vbDirectory)) = 0 Then
        MsgBox "'" & sourceFolder & "' not found!", vbExclamation
        Exit Sub
    End If
    
    'set the path to the destination folder (change accordingly)
    destFolder = "C:\Users\Domenic\Desktop\Folder2\"
    
    'ensure the path to the destination folder ends with a backslash (\)
    If Right(destFolder, 1) <> "\" Then
        destFolder = destFolder & "\"
    End If
    
    'make sure destination folder exists
    If Len(Dir(destFolder, vbDirectory)) = 0 Then
        MsgBox "'" & destFolder & "' not found!", vbExclamation
        Exit Sub
    End If
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    
    'set the list of files to process (add and/or change the names accordingly)
    targetFiles = Array("file1.xlsm", "file2.xlsm", "file3.xlsm")
    
    'loop through each target file for processing
    fileCount = 0
    For Each currentFile In targetFiles
        'set the path and filename for the current file
        pathAndFilename = sourceFolder & currentFile
        'process file, if it exists
        If Len(Dir(pathAndFilename, vbNormal)) > 0 Then
            'increment file count
            fileCount = fileCount + 1
            'open the current file and update the links
            Set currentWorkbook = Workbooks.Open(Filename:=pathAndFilename, UpdateLinks:=True)
            'get the links from the current workbook
            linkSources = currentWorkbook.linkSources(xlExcelLinks)
            'break the links in the current workbook, if they exist
            If Not IsEmpty(linkSources) Then
                For Each currentLink In linkSources
                    currentWorkbook.BreakLink currentLink, xlLinkTypeExcelLinks
                Next currentLink
            End If
            With currentWorkbook
                'save the current workbook to the destination folder, overwrite if one with the same name already exists
                .SaveAs Filename:=destFolder & currentWorkbook.Name
                'close the current workbook
                .Close savechanges:=False
            End With
        End If
    Next currentFile
    
    'clear from memory
    Set currentWorkbook = Nothing
    
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
    MsgBox "Processed files: " & fileCount, vbInformation
    
End Sub

Hope this helps!

 

[kyddrivers]

Thank you very much!!!!!!

Worked like a charm!

 

[Domenic]

You're very welcome. Thanks for the feedback.

Cheers!