Loop code through Range

[vintage88]

Greetings

Recently I have been working on a VBA that does the following while launched in a separate macro-enabled Excel file:
1. Open Workbook1 in a separate process and choses a unit in validation list (drop-down menu list, what changes data on the Sheet1)
2. Copy Sheet1 to a new workbook (in order to keep the original file untouched)
3. Delete links in cells and images to any other sheets/workbooks
4. Save the Sheet1
5. Goes back to Workbook1 and loop 1~3 until the last unit in validation list.


So, the problem is that when the code goes through the first time it deletes links, so the following steps are corrupted. I'm kinda lost in the code, can get how to fix this, would appreciate help.

 

[vintage88]

Dim fileCollection As Collection
Sub TraversePath(path As String)
    Dim currentPath As String, directory As Variant
    Dim dirCollection As Collection
    Set dirCollection = New Collection
    
    currentPath = Dir(path, vbDirectory)
    
    'Explore current directory
    Do Until currentPath = vbNullString
        Debug.Print currentPath
        If Left(currentPath, 1) <> "." And (GetAttr(path & currentPath) And vbDirectory) = vbDirectory Then
            dirCollection.Add currentPath
        ElseIf Left(currentPath, 1) <> "." And (GetAttr(path & currentPath) And vbNormal) = vbNormal Then
            fileCollection.Add path & currentPath
        End If
        currentPath = Dir()
    Loop
    
    'Explore subsequent directories
    For Each directory In dirCollection
        Debug.Print "---SubDirectory: " & directory & "---"
        TraversePath path & directory & "\"
    Next directory
End Sub

Sub RunOnAllFilesInSubFoldersExcel()

    Dim folderName As String, eApp As Excel.Application, fileName As Variant
    Dim wb As Workbook, ws As Worksheet, currWs As Worksheet, currWb As Workbook
    Dim fDialog As Object: Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    Dim inputRange As Range
    Dim Var, s As String, t As String, c As Range
    Dim newFolderFullName As String
    Dim ExternalLinks As Variant
    Dim x As Long
    Dim lngCount    As Long
    Dim rng As Range
    Dim names As Collection, name, pic As Shape
    Dim nwb As Workbook
    Dim CellsWithFormula As Range
     
     
    Set currWb = ActiveWorkbook: Set currWs = ActiveSheet
   
'Links = currWb.LinkSources(Type:=xlLinkTypeExcelLinks)
   
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
   
'Select folder in which all files are stored
    fDialog.Title = "Select a folder"
    fDialog.InitialFileName = Left(currWb.path, InStrRev(currWb.path, "\") - 1)
    If fDialog.Show = -1 Then
      folderName = fDialog.SelectedItems(1)
    End If
   
'Create a separate Excel process that is invisibile
    Set eApp = New Excel.Application:  eApp.Visible = False
   ' Set eApp2 = New Excel.Application: eApp2.Visible = False
   
    'Search for all files in folder [replace *.* with your pattern e.g. *.xlsx]
    Set fileCollection = New Collection
    TraversePath folderName & "\"
    
    
    For Each fileName In fileCollection
   
'Update status bar to indicate progress
        Application.StatusBar = "Processing " & fileName
       
' Setting full name for the folder where Excel filed of the activeworkbook should be saved
' Getting name from the full file name
        Var = Mid(fileName, InStrRev(fileName, "\") + 1)
' Slicing file extension off
        Var = Left(Var, InStrRev(Var, ".") - 1)
' Setting full folder name
        newFolderFullName = currWb.path & "\" & Var & "-Excel"

' Creating a folder if there is no such
        If Dir(newFolderFullName, vbDirectory) = "" Then
            MkDir newFolderFullName
        End If
       
' Open file
        Set wb = eApp.Workbooks.Open(fileName:=fileName, ReadOnly:=True)
       
' Link to the 1st sheet of the file
        Set ws = wb.Worksheets(1)
             
        Set inputRange = eApp.Evaluate(ws.Range("B4").Validation.Formula1)
         
'Loop drop-down models list listing
        For Each c In inputRange
            ws.Range("B4").Value = c.Value
            s = ws.Range("B4").Value
            t = ws.Range("B5").Value
            f = ws.Range("B6").Value

wb.Sheets("Sheet1").Copy Before:=eApp.Sheets(1)

             'Remove links from images(works) START
                         On Error Resume Next
                         Set names = New Collection
                         For Each pic In ws.Shapes
                             name = pic.DrawingObject.Formula
                             If name <> "" Then
                                 name = Trim(name)
                                 names.Add Key:=name, Item:=name
                             End If
                         Next pic
                         On Error GoTo 0
                        
            'Deleting formulas from the pictures.
                         For Each pic In ws.Shapes
                             pic.DrawingObject.Formula = ""
                         Next pic
                        
            'Clearing name used by pictures END
                         On Error Resume Next
                         For Each name In names
                             wb.names(name).Delete
                         Next name
                         On Error GoTo 0
            
                         
             'Remove links from cells(works) START
                        On Error Resume Next
                        Set CellsWithFormula = wb.Worksheets("Sheet1").UsedRange.SpecialCells(xlCellTypeFormulas)
                        On Error GoTo 0
                    
                        If Not CellsWithFormula Is Nothing Then
                            Application.Calculation = xlCalculationManual
                    
                            Dim Area As Range
                            For Each Area In CellsWithFormula.Areas
                                Area.Value = Area.Value
                            Next Area
                    
                            Application.Calculation = xlCalculationAutomatic
                            
                        End If
                
             'Remove links from cells(works)  END
                
                       wb.Application.ActiveWorkbook.SaveAs newFolderFullName & "/" & f & "_" & s & "-Excel", FileFormat:=51
                       Next c
            
                    wb.Close savechanges:=False 'Closes open Workbook w/o saving
                    Debug.Print "Processed " & fileName  'Progress indication
       
    Next fileName
   
    eApp.Quit
    Set eApp = Nothing
'Clear statusbar and notify of macro completion
    Application.StatusBar = ""
   
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

    MsgBox "Completed executing macro on all workbooks"
   
End Sub

 

[vintage88]

' Open file Set wb = eApp.Workbooks.Open(fileName:=fileName, ReadOnly:=True)

this is the part starting from where I would like get support and possible solutions suggestion