Loop macro works on individual sheets, but locks up when looping through multiple sheets.

[TrainingExcellence]

Greetings!

I've been learning VBA and have found this forum to be extremely helpful! This is my first post. I'm having trouble with a macro I'm creating at work. I have a number of xls-refreshable reports exported from another software program. The macro I'm creating is meant to move all relevant information onto one sheet (Consolidation) from which I will create a pivot table. Each worksheet has its own data connection. The strange thing is the following code works when I run it on individual worksheets (using step-into mode), but when I run the entire code, looping through each sheet in workbook, it locks up. I don't understand why. Is there anything obviously wrong with the code?

Sub LearningPlans()

'Tweaks to speed up macros
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False


'Unhide all worksheets
    Dim ws As Worksheet
 
    For Each ws In ActiveWorkbook.Worksheets
        ws.Visible = xlSheetVisible
    Next ws
            
'Setup a worksheet called "Consolidation" to which you will compile data from all other worksheets. The "Consolidation" sheet will be used to build a pivot table.
    With Sheets("Consolidation")
        .UsedRange.ClearContents
        .Range("A1:A2").FormulaR1C1 = "Employee Name"
        .Range("B1:B2").FormulaR1C1 = "Title"
        .Range("C1:C2").FormulaR1C1 = "Trainings"
        .Range("D1:D2").FormulaR1C1 = "Status"
        .Range("A2:D2").Font.Bold = True
    End With


'Format every data sheet and copy select data to the "Consolidation" sheet.
    
    Sheets(1).Select
    
    Do Until ActiveSheet.Name = "Consolidation"
        
    'Refresh data
        ActiveSheet.UsedRange.ClearContents
        With Range("A1").QueryTable
        .BackgroundQuery = False
        .Refresh
        End With
            
    ' Undo wrap text and switch to General
        With Range("A1").CurrentRegion
            .WrapText = False
            .NumberFormat = "general"
        End With
    
    'Concatenate employees' names
        Range("B:B").Insert Shift:=xlToRight
        Range("B1").FormulaR1C1 = "Employee Name"
        Range("B1").Offset(1, 1).Range("A1").Select
        
        Do Until ActiveCell = ""
            ActiveCell.Offset(0, -1).Range("A1").FormulaR1C1 = "=CONCATENATE(RC[2],"" "",RC[1])"
            ActiveCell.Offset(1, 0).Range("A1").Select
        Loop
             
        With Range("b1", Range("b1").End(xlDown))
        .Copy
        .PasteSpecial Paste:=xlPasteValues
        End With
        
    'Insert two columns next to each course column. One column displays the course name in every row of the range, and the second column displays "Needs Training" or "Passed" in each of its rows.
        Selection.End(xlToRight).Offset(0, -2).Select
        Do Until ActiveCell = "Date of Hire" 'Loops right to left of worksheet through each of the course columns.
        i = i + 1 'Counts the number of loop iterations. Used later in the macro.
            ActiveCell.Resize(, 2).EntireColumn.Insert
            ActiveCell.FormulaR1C1 = "Courses"
            ActiveCell.Offset(0, 1).FormulaR1C1 = "=RC[1]"
            ActiveCell.Offset(1, 2).Select
        
        Do Until ActiveCell = ""
        With ActiveCell
        .Offset(0, -1).FormulaR1C1 = _
                "=IF(RC[1]=""Not Attempted"",""Needs Training"",IF(RC[1]=""In Progress"",""Needs Training"",""Passed""))"
        .Offset(0, -2).FormulaR1C1 = "=R1C[2]"
        End With
        ActiveCell.Offset(1, 0).Select
        Loop
        Selection.Offset(-1, 0).End(xlUp).Offset(0, -2).Range("a1:b1").Select
        Range(Selection, Selection.End(xlDown)).Copy
        Selection.PasteSpecial Paste:=xlPasteValues
        
    'Send data to "Consolidation" sheet
        numRows = Selection.Rows.Count
        numColumns = Selection.Columns.Count
        Selection.Resize(numRows - 1, numColumns).Select
        Selection.Offset(1, 0).Select
        Dim CurrentWorksheet As Range
        Set CurrentWorksheet = Selection
        Dim ConsolidationCourses As Range
        Set ConsolidationCourses = Worksheets("Consolidation").Range("c1").End(xlDown).Offset(1, 0)
        CurrentWorksheet.Copy Destination:=ConsolidationCourses
        ActiveCell.Offset(-1, -1).Select
        
        Loop 'Repeat on remaining courses
    
        ActiveCell.Offset(0, -5).End(xlDown).Select
        Range(Selection, Selection.End(xlUp).Offset(1, 0)).Select
        
        For counter = 1 To i
        
        Set CurrentWorksheet = Selection
        Dim strEmployeeNames As Range
        Set strEmployeeNames = Worksheets("Consolidation").Range("a1").End(xlDown).Offset(1, 0)
        CurrentWorksheet.Copy Destination:=strEmployeeNames
        
        Next
        
        Do Until ActiveCell = ""
        ActiveCell.Offset(0, 3).Formula = ActiveSheet.Name
        ActiveCell.Offset(1, 0).Select
        Loop
        
        Range(ActiveCell.Offset(-1, 3), ActiveCell.Offset(-1, 3).End(xlUp).Offset(1, 0)).Select
        With Selection
        .Copy
        .PasteSpecial Paste:=xlPasteValues
        End With
        
        For counter = 1 To i
        Set CurrentWorksheet = Selection
        Dim strEmployeeTitles As Range
        Set strEmployeeTitles = Worksheets("Consolidation").Range("b1").End(xlDown).Offset(1, 0)
        CurrentWorksheet.Copy Destination:=strEmployeeTitles
        Next
        
        ActiveWindow.ActiveSheet.Visible = False
        Loop
        
    'Speed up macros, ending
        Application.Calculation = xlCalculationAutomatic
        Application.DisplayStatusBar = True
        Application.EnableEvents = True
        ActiveSheet.DisplayPageBreaks = True
        Application.ScreenUpdating = True
        
    End Sub

Thanks!
Ben

 

[StephenCrump]

Welcome to the Forum!

I might be missing something, but based on a quick look, you have:

Sheets(1).Select

Do Until ActiveSheet.Name = "Consolidation"
        
     'lots of code that doesn't change the ActiveSheet
        
Loop

If Sheets(1) isn't "Consolidation", your loop won't terminate.

 

[footoo]

Instead of :

Do Until ActiveSheet.Name = "Consolidation"
'your code
Loop

Try :

Dim ws As Worksheet
For Each ws In Worksheets
    If ws.Name <> "Consolidation" Then
        ws.Activate
        'your code
    End If
Next

 

[TrainingExcellence]

Ahh, StephenCrump, that totally makes sense. I'm pretty sure it is just in a perpetual loop.

Thanks footoo, but for some reason the macro isn't stopping when it comes to the Consolidation worksheet. It jumps back to the first sheet and loops again. How do I get it to stop looping when it comes to the and proceed with the rest of the macro?

You guys rock! Thanks!

 

[footoo]

Thanks footoo, but for some reason the macro isn't stopping when it comes to the Consolidation worksheet. It jumps back to the first sheet and loops again. How do I get it to stop looping when it comes to the and proceed with the rest of the macro?

Step through the macro via F8 to see where it's going astray. Then revise accordingly.

 

[xenou]

There should be no uses of .Select or references to ActiveCell anywhere in your code. That will help all your vba work, as a general rule, and it may be the cause of a hard to spot error in this one.

Also I'd prefer to do a single RefreshAll at the beginning rather than refreshing each worksheet in the loop (refreshes are difficult to manage so if you can isolate that to a single step by itself it's one less variable to manage in the remaining code).

 

[TrainingExcellence]

Step through the macro via F8 to see where it's going astray. Then revise accordingly.

Okay, so here is what I notice. When I put a break at the Next statement (the one towards the end of the script) and press f5 to move through each interval, the macro works perfectly. But when I remove the break and run the macro without interruption, it locks up. I don't know what to think.

Sub LearningPlans()


'Tweaks to speed up macros
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False


'Unhide all worksheets
    Dim ws As Worksheet
 
    For Each ws In ActiveWorkbook.Worksheets
        ws.Visible = xlSheetVisible
    Next ws
            
'Setup a worksheet called "Consolidation" to which you will compile data from all other worksheets. The "Consolidation" sheet will be used to build a pivot table.
    With Sheets("Consolidation")
        .UsedRange.ClearContents
        .Range("A1:A2").FormulaR1C1 = "Employee Name"
        .Range("B1:B2").FormulaR1C1 = "Title"
        .Range("C1:C2").FormulaR1C1 = "Trainings"
        .Range("D1:D2").FormulaR1C1 = "Status"
        .Range("A2:D2").Font.Bold = True
    End With


'Format every data sheet and copy select data to the "Consolidation" sheet.
    
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "Consolidation" Then
        ws.Activate
          
    'Refresh data
        ActiveSheet.UsedRange.ClearContents
        With Range("A1").QueryTable
        .BackgroundQuery = False
        .Refresh
        End With
            
    ' Undo wrap text and switch to General
        With Range("A1").CurrentRegion
            .WrapText = False
            .NumberFormat = "general"
        End With


    'Concatenate employees' names
        Range("B:B").Insert Shift:=xlToRight
        Range("B1").FormulaR1C1 = "Employee Name"
        Range("B1").Offset(1, 1).Range("A1").Select


        Do Until ActiveCell = ""
            ActiveCell.Offset(0, -1).Range("A1").FormulaR1C1 = "=CONCATENATE(RC[2],"" "",RC[1])"
            ActiveCell.Offset(1, 0).Range("A1").Select
        Loop


        With Range("b1", Range("b1").End(xlDown))
        .Copy
        .PasteSpecial Paste:=xlPasteValues
        End With


    'Insert two columns next to each course column. One column displays the course name in every row of the range, and the second column displays "Needs Training" or "Passed" in each of its rows.
        Selection.End(xlToRight).Offset(0, -2).Select
        Do Until ActiveCell = "Date of Hire" 'Loops right to left of worksheet through each of the course columns.
        i = i + 1 'Counts the number of loop iterations. Used later in the macro.
            ActiveCell.Resize(, 2).EntireColumn.Insert
            ActiveCell.FormulaR1C1 = "Courses"
            ActiveCell.Offset(0, 1).FormulaR1C1 = "=RC[1]"
            ActiveCell.Offset(1, 2).Select


        Do Until ActiveCell = ""
        With ActiveCell
        .Offset(0, -1).FormulaR1C1 = _
                "=IF(RC[1]=""Not Attempted"",""Needs Training"",IF(RC[1]=""In Progress"",""Needs Training"",""Passed""))"
        .Offset(0, -2).FormulaR1C1 = "=R1C[2]"
        End With
        ActiveCell.Offset(1, 0).Select
        Loop
        Selection.Offset(-1, 0).End(xlUp).Offset(0, -2).Range("a1:b1").Select
        Range(Selection, Selection.End(xlDown)).Copy
        Selection.PasteSpecial Paste:=xlPasteValues


    'Send data to "Consolidation" sheet
        numRows = Selection.Rows.Count
        numColumns = Selection.Columns.Count
        Selection.Resize(numRows - 1, numColumns).Select
        Selection.Offset(1, 0).Select
        Dim CurrentWorksheet As Range
        Set CurrentWorksheet = Selection
        Dim ConsolidationCourses As Range
        Set ConsolidationCourses = Worksheets("Consolidation").Range("c1").End(xlDown).Offset(1, 0)
        CurrentWorksheet.Copy Destination:=ConsolidationCourses
        ActiveCell.Offset(-1, -1).Select


        Loop 'Repeat on remaining courses
    
        ActiveCell.Offset(0, -5).End(xlDown).Select
        Range(Selection, Selection.End(xlUp).Offset(1, 0)).Select
    
        For counter = 1 To i
    
        Set CurrentWorksheet = Selection
        Dim strEmployeeNames As Range
        Set strEmployeeNames = Worksheets("Consolidation").Range("a1").End(xlDown).Offset(1, 0)
        CurrentWorksheet.Copy Destination:=strEmployeeNames
    
        Next
    
        Do Until ActiveCell = ""
        ActiveCell.Offset(0, 3).Formula = ActiveSheet.Name
        ActiveCell.Offset(1, 0).Select
        Loop
    
        Range(ActiveCell.Offset(-1, 3), ActiveCell.Offset(-1, 3).End(xlUp).Offset(1, 0)).Select
        With Selection
        .Copy
        .PasteSpecial Paste:=xlPasteValues
        End With
    
        For counter = 1 To i
        Set CurrentWorksheet = Selection
        Dim strEmployeeTitles As Range
        Set strEmployeeTitles = Worksheets("Consolidation").Range("b1").End(xlDown).Offset(1, 0)
        CurrentWorksheet.Copy Destination:=strEmployeeTitles
        Next
           
        ActiveWindow.ActiveSheet.Visible = False


End If
Next


        Sheets("Consolidation").UsedRange.Select
        numRowsConsolidation = Selection.Rows.Count
        numColumnsConsolidation = Selection.Columns.Count
        Selection.Resize(numRowsConsolidation - 1, numColumnsConsolidation).Select
        Selection.Offset(1, 0).Select
        


        Application.Calculation = xlCalculationAutomatic
        Application.DisplayStatusBar = True
        Application.EnableEvents = True


        Application.ScreenUpdating = True
        
    End Sub

 

[xenou]

how many sheets are you dealing with?

 

[TrainingExcellence]

how many sheets are you dealing with?

It varies depending upon the workbook, but I'd say up to a dozen or so worksheets.

 

[footoo]

Try removing these lines :
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
ActiveSheet.DisplayPageBreaks = False

If that fixes it, try adding them back one by one.

Also, could try putting DoEvents in the Refresh Data bit of code.