0

I have a macro that loops through the files in a folder in which the original excel with the macro lies. It then does a bunch of copy paste for each of the files in the folder. The macro works correctly for the first file in the folder, however, it then stops. Does anyone know why this is so (the starts when it says "Get the list of other tabs (column A)")? There are no errors, the macro just stops looping.

Sub ListSheets()

    'Call NewFileTabs
    
    Application.ScreenUpdating = False
    Const ProcName As String = "ListSheets"
    Dim IsSuccess As Boolean
    'On Error GoTo ClearError

    'Define locations of where to write
    Const dName As String = "Engine"
    Const dfcAddress As String = "A1" 'where to write old file tabs
    Const dfcAddress_new_file As String = "B1" 'where to write new file tabs
    
    Dim wb_macro As Workbook: Set wb_macro = ThisWorkbook ' workbook containing this code
    Dim ws_macro As Worksheet: Set ws_macro = wb_macro.Worksheets(dName)
    Dim macro_filename As String: macro_filename = wb_macro.Name
    Dim dCell As range: Set dCell = ws_macro.range(dfcAddress) 'where to write old tabs
    Dim dCell_new As range: Set dCell_new = ws_macro.range(dfcAddress_new_file) 'where to write new tabs
    
    Dim sFolderPath As String: sFolderPath = wb_macro.Path & "\"
    Dim sFileName As String: sFileName = Dir(sFolderPath & "*.xls*")
    
    Application.EnableEvents = False
    
    Dim wb_from As Workbook
    Dim new_wb As Workbook
    Dim sheet As Object
    Dim sht_new As Object
    Dim sFilePath As String
    Dim sFilePath_newfile As String
    Dim dData As Variant
    Dim dData_1 As Variant
    Dim NewTemplate As Variant
    Dim from_nr_sheet As Long
    Dim nr_sheet_new_file As Long
    Dim dr As Long
    Dim dr_new As Long
    
    Dim miss_tab As String
    
    'Get the list of new file tabs (column B)
    
    NewTemplate = Application.GetOpenFilename
    
    If NewTemplate <> False Then
        
        Set new_wb = Workbooks.Open(NewTemplate)
        Dim new_wb_name As String: new_wb_name = new_wb.Name
        Dim sFolderPath_new As String: sFolderPath_new = new_wb.Path & "\"
        Dim sFileName_new As String: sFileName_new = Dir(sFolderPath_new & "*.xls*")
        sFilePath_newfile = sFolderPath_new & sFileName_new
        nr_sheet_new_file = new_wb.Sheets.Count + 1
        ReDim dData_1(1 To nr_sheet_new_file, 1 To 1)
        dData_1(1, 1) = sFilePath_newfile
        dr_new = 1
        For Each sht_new In new_wb.Sheets
            dr_new = dr_new + 1
            dData_1(dr_new, 1) = sht_new.Name
        Next sht_new
        'new_wb.Close SaveChanges:=False
        range(dCell_new, dCell_new.Offset(UBound(dData_1, 1) - 1)) = dData_1
        End If
    IsSuccess = True
        
    'Get the list of other tabs (column A)
    Do While Len(sFileName) > 0
        If StrComp(sFileName, macro_filename, vbTextCompare) <> 0 Then
            sFilePath = sFolderPath & sFileName
            Set wb_from = Workbooks.Open(sFilePath)
            from_nr_sheet = wb_from.Sheets.Count + 1 ' + 1 for header
            ReDim dData(1 To from_nr_sheet, 1 To 1)
            dData(1, 1) = sFilePath ' sFileName - write header
            dr = 1
            For Each sheet In wb_from.Sheets
                dr = dr + 1
                dData(dr, 1) = sheet.Name
            Next sheet
            'wb_from.Close SaveChanges:=False ' it was just read from
            dCell.Resize(from_nr_sheet).Value = dData ' write to destination worksheet
            'Set dCell = dCell.Offset(, 1) ' next column
            
            'Copy the tabs over
            Workbooks(macro_filename).Sheets("Engine").Activate
            Dim rng As range: Set rng = ActiveSheet.range("F2:F100")
            Dim cel As range
            
            For Each cel In rng 'look at first 100 different tabs
                 If Not cel.Value = "" Then
                    miss_tab = cel.Value
                    
                    wb_from.Sheets(cel.Value).Copy Before:=Workbooks(new_wb_name).Sheets("Core")
                End If
            Next cel
            wb_from.Close SaveChanges:=False
            new_wb.SaveAs Filename:=sFolderPath_new & sFileName
        End If
        sFileName = Dir
        Workbooks(macro_filename).Sheets("Engine").Activate
        Sheets("Engine").range("A1:B100").ClearContents
   Loop
   
   new_wb.Close SaveChanges:=False
   
   IsSuccess = True

    Application.ScreenUpdating = True
End Sub
mohamed123
  • 31
  • 9
  • My guess is that Excel is getting confused when you are using `Activate` on other workbooks. Be careful how you're using references and [avoid using `Select` and `Activate`](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba). See if that helps. – PeterT Mar 01 '22 at 15:29

2 Answers2

0

While it may be difficult to determine why it stops looping by observation/review...code can usually be re-organized to help narrow down where/what the problem is.

Given that it currently stops looping after processing the first file, it is clear that Dir is (for whatever reason) returning an empty string after the first file is processed. A first step to debugging the issue would be to isolate the task of getting all the filepaths. Once all the filepaths are determined, Then operate on each file of interest. This step is implemented in the code below.

If loading the filepaths separately fails, then you have a lot less code to debug. If all the filepaths load successfully and the code still fails, then the problem is within the subsequent loop.

As has been commented, it is possible that the code within the Do While loop is somehow preventing Dir from operating properly. If this is the case, then the code below might get the code to work. If the code still fails after collating the filepaths of interest, then start parsing out blocks of functionality within If StrComp(sFileName, macro_filename, vbTextCompare) <> 0 Then. Good luck!

Sub ListSheets()

    'Call NewFileTabs
    
    Application.ScreenUpdating = False
    Const ProcName As String = "ListSheets"
    Dim IsSuccess As Boolean
    'On Error GoTo ClearError

    'Define locations of where to write
    Const dName As String = "Engine"
    Const dfcAddress As String = "A1" 'where to write old file tabs
    Const dfcAddress_new_file As String = "B1" 'where to write new file tabs
    
    Dim wb_macro As Workbook: Set wb_macro = ThisWorkbook ' workbook containing this code
    Dim ws_macro As Worksheet: Set ws_macro = wb_macro.Worksheets(dName)
    Dim macro_filename As String: macro_filename = wb_macro.Name
    Dim dCell As Range: Set dCell = ws_macro.Range(dfcAddress) 'where to write old tabs
    Dim dCell_new As Range: Set dCell_new = ws_macro.Range(dfcAddress_new_file) 'where to write new tabs
    
    Dim sFolderPath As String: sFolderPath = wb_macro.Path & "\"
    
    Application.EnableEvents = False
    
    Dim wb_from As Workbook
    Dim new_wb As Workbook
    Dim sheet As Object
    Dim sht_new As Object
    Dim sFilePath As String
    Dim sFilePath_newfile As String
    Dim dData As Variant
    Dim dData_1 As Variant
    Dim NewTemplate As Variant
    Dim from_nr_sheet As Long
    Dim nr_sheet_new_file As Long
    Dim dr As Long
    Dim dr_new As Long
    
    Dim miss_tab As String
    
    'Get the list of new file tabs (column B)
    
    NewTemplate = Application.GetOpenFilename
    
    If NewTemplate <> False Then
        
        Set new_wb = Workbooks.Open(NewTemplate)
        Dim new_wb_name As String: new_wb_name = new_wb.Name
        Dim sFolderPath_new As String: sFolderPath_new = new_wb.Path & "\"
        Dim sFileName_new As String: sFileName_new = Dir(sFolderPath_new & "*.xls*")
        sFilePath_newfile = sFolderPath_new & sFileName_new
        nr_sheet_new_file = new_wb.Sheets.Count + 1
        ReDim dData_1(1 To nr_sheet_new_file, 1 To 1)
        dData_1(1, 1) = sFilePath_newfile
        dr_new = 1
        For Each sht_new In new_wb.Sheets
            dr_new = dr_new + 1
            dData_1(dr_new, 1) = sht_new.Name
        Next sht_new
        'new_wb.Close SaveChanges:=False
        Range(dCell_new, dCell_new.Offset(UBound(dData_1, 1) - 1)) = dData_1
        End If
    IsSuccess = True
        
    'Determine all the filepaths in a dedicated loop.
    'If this succeeds, the issue is somewhere else
    'or the other code is somehow preventing 'Dir' from succeeding
    Dim filesOfInterest As Collection
    Set filesOfInterest = New Collection
    
    Dim sFileName As String
    sFileName = Dir(sFolderPath & "*.xls*")
    
    Do While Len(sFileName) > 0
        filesOfInterest.Add sFileName
        sFileName = Dir
    Loop
    
    'Get the list of other tabs (column A)
    
    'Operate on all the filepaths
    Dim fileOfInterest As Variant
    For Each fileOfInterest In filesOfInterest
        If StrComp(fileOfInterest, macro_filename, vbTextCompare) <> 0 Then
            sFilePath = sFolderPath & fileOfInterest
            Set wb_from = Workbooks.Open(sFilePath)
            from_nr_sheet = wb_from.Sheets.Count + 1 ' + 1 for header
            ReDim dData(1 To from_nr_sheet, 1 To 1)
            dData(1, 1) = sFilePath ' sFileName - write header
            dr = 1
            For Each sheet In wb_from.Sheets
                dr = dr + 1
                dData(dr, 1) = sheet.Name
            Next sheet
            'wb_from.Close SaveChanges:=False ' it was just read from
            dCell.Resize(from_nr_sheet).Value = dData ' write to destination worksheet
            'Set dCell = dCell.Offset(, 1) ' next column
            
            'Copy the tabs over
            Workbooks(macro_filename).Sheets("Engine").Activate
            Dim rng As Range: Set rng = ActiveSheet.Range("F2:F100")
            Dim cel As Range
            
            For Each cel In rng 'look at first 100 different tabs
                 If Not cel.Value = "" Then
                    miss_tab = cel.Value
                    
                    wb_from.Sheets(cel.Value).Copy Before:=Workbooks(new_wb_name).Sheets("Core")
                End If
            Next cel
            wb_from.Close SaveChanges:=False
            new_wb.SaveAs Filename:=sFolderPath_new & fileOfInterest
        End If
        Workbooks(macro_filename).Sheets("Engine").Activate
        Sheets("Engine").Range("A1:B100").ClearContents
   Next
   
   new_wb.Close SaveChanges:=False
   
   IsSuccess = True

    Application.ScreenUpdating = True
End Sub
BZngr
  • 671
  • 5
  • 6
0

This worked for me in the end if anyone needs the full code. It takes the answer above, and just adjusts some of the variables:

Sub ListSheets()

    'Call NewFileTabs
    
    Application.ScreenUpdating = False
    Const ProcName As String = "ListSheets"
    Dim IsSuccess As Boolean
    'On Error GoTo ClearError

    'Define locations of where to write
    Const dName As String = "Engine"
    Const dfcAddress As String = "A1" 'where to write old file tabs
    Const dfcAddress_new_file As String = "B1" 'where to write new file tabs
    
    Dim wb_macro As Workbook: Set wb_macro = ThisWorkbook ' workbook containing this code
    Dim ws_macro As Worksheet: Set ws_macro = wb_macro.Worksheets(dName)
    Dim macro_filename As String: macro_filename = wb_macro.Name
    Dim dCell As range: Set dCell = ws_macro.range(dfcAddress) 'where to write old tabs
    Dim dCell_new As range: Set dCell_new = ws_macro.range(dfcAddress_new_file) 'where to write new tabs
    
    Dim sFolderPath As String: sFolderPath = wb_macro.Path & "\"
    
    Application.EnableEvents = False
    
    Dim wb_from As Workbook
    Dim new_wb As Workbook
    Dim sheet As Object
    Dim sht_new As Object
    Dim sFilePath As String
    Dim sFilePath_newfile As String
    Dim dData As Variant
    Dim dData_1 As Variant
    Dim NewTemplate As Variant
    Dim from_nr_sheet As Long
    Dim nr_sheet_new_file As Long
    Dim dr As Long
    Dim dr_new As Long
    
    Dim miss_tab As String
    
    'Get the list of new file tabs (column B)
    
    NewTemplate = Application.GetOpenFilename
    
    If NewTemplate <> False Then
        
        Set new_wb = Workbooks.Open(NewTemplate)
        Dim new_wb_name As String: new_wb_name = new_wb.Name
        Dim sFolderPath_new As String: sFolderPath_new = new_wb.Path & "\"
        Dim sFileName_new As String: sFileName_new = Dir(sFolderPath_new & "*.xls*")
        sFilePath_newfile = sFolderPath_new & sFileName_new
        nr_sheet_new_file = new_wb.Sheets.Count + 1
        ReDim dData_1(1 To nr_sheet_new_file, 1 To 1)
        dData_1(1, 1) = sFilePath_newfile
        dr_new = 1
        For Each sht_new In new_wb.Sheets
            dr_new = dr_new + 1
            dData_1(dr_new, 1) = sht_new.Name
        Next sht_new
        'new_wb.Close SaveChanges:=False
        range(dCell_new, dCell_new.Offset(UBound(dData_1, 1) - 1)) = dData_1
        End If
    IsSuccess = True
        
    'Determine all the filepaths in a dedicated loop.
    'If this succeeds, the issue is somewhere else
    'or the other code is somehow preventing 'Dir' from succeeding
    Dim filesOfInterest As Collection
    Set filesOfInterest = New Collection
    
    Dim sFileName As String
    sFileName = Dir(sFolderPath & "*.xls*")
    
    Do While Len(sFileName) > 0
        filesOfInterest.Add sFileName
        sFileName = Dir
    Loop
    
    'Get the list of other tabs (column A)
    
    'Operate on all the filepaths
    Dim fileOfInterest As Variant
    For Each fileOfInterest In filesOfInterest
        If StrComp(fileOfInterest, macro_filename, vbTextCompare) <> 0 Then
            sFilePath = sFolderPath & fileOfInterest
            Set wb_from = Workbooks.Open(sFilePath)
            from_nr_sheet = wb_from.Sheets.Count + 1 ' + 1 for header
            ReDim dData(1 To from_nr_sheet, 1 To 1)
            dData(1, 1) = sFilePath ' sFileName - write header
            dr = 1
            For Each sheet In wb_from.Sheets
                dr = dr + 1
                dData(dr, 1) = sheet.Name
            Next sheet
            'wb_from.Close SaveChanges:=False ' it was just read from
            dCell.Resize(from_nr_sheet).Value = dData ' write to destination worksheet
            'Set dCell = dCell.Offset(, 1) ' next column
            
            'Copy the tabs over
            Workbooks(macro_filename).Sheets("Engine").Activate
            Dim rng As range: Set rng = ActiveSheet.range("F2:F100")
            Dim cel As range
            
            For Each cel In rng 'look at first 100 different rows
                 If Not cel.Value = "" Then
                    miss_tab = cel.Value
                    
                    wb_from.Sheets(cel.Value).Copy Before:=Workbooks(new_wb_name).Sheets("Core")
                End If
            Next cel
            wb_from.Close SaveChanges:=False
            new_wb.SaveAs Filename:=sFolderPath_new & fileOfInterest
            Set new_wb = Workbooks.Open(sFilePath_newfile)
        End If
        Workbooks(macro_filename).Sheets("Engine").Activate
        Sheets("Engine").range("A1:A100").ClearContents
   Next
   
   Sheets("Engine").range("A1:A100").ClearContents
   new_wb.Close SaveChanges:=False
   
   IsSuccess = True

    Application.ScreenUpdating = True
End Sub
mohamed123
  • 31
  • 9