Worksheet Looping not working for all the sheets

[Blue_kul]

Hi All,

I am trying to run below Macro for several worksheets in a workbook (For an instance, lets assume 3 sheets)

Though the initial sorting part is getting executed for all the three worksheets but rest of code is not.

Please suggest what changes need to be carried out in the code below so as to make it worksheets friendly/usable.

Code :
----------------------------------------------------------------------------

Private Sub CommandButton1_Click()

'Active WorkSheets Calculation
Dim Ws_Count As Integer
Dim Q As Integer

Ws_Count = ActiveWorkbook.Worksheets.Count

'Loop to run through all worksheets
For Q = 1 To Ws_Count

MsgBox ActiveWorkbook.Worksheets(Q).Name

' Sorting of Data
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    ActiveWorkbook.Worksheets(Q).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(Q).Sort.SortFields.Add Key:=Range("B:B"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(Q).Sort.SortFields.Add Key:=Range("E:E"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(Q).Sort.SortFields.Add Key:=Range("F:F"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(Q).Sort.SortFields.Add Key:=Range("G:G"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(Q).Sort.SortFields.Add Key:=Range("D:D"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(Q).Sort
        .SetRange Range("A:G")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
' Sorting Ends

'------------Code works till here ------------

' Active Row Count
'RowCount = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row - 1
Dim RowCount As Long
RowCount = Range("A1").CurrentRegion.Rows.Count
'MsgBox "The number of rows is " & RowCount
' Row Count Ends

'Cell Count Variable Declaration And Initialization
Dim X As Integer, Y As Integer
Dim A As Integer, B As Integer
X = 2
Y = 2
A = 2
B = 5
'Declaration And Initialization Ends

'Sum Variable Declaration And Initialization
Dim Total1 As Double, Total2 As Double, TotalSum As Double
Total1 = 0
Total2 = 0
SumTotal = 0
'Declaration And Initialization Ends


' Data Reconcilation Start
For I = 1 To RowCount

' Empty Cell Check
If Cells(X, Y).Value <> "" Then

' Currency Check
If Cells(X, Y).Value = Cells(X + 1, Y) Then

'Abs Total Check
If Cells(A, B).Value = Cells(A + 1, B) Then

Total1 = Cells(A, 6).Value + Cells(A, 7).Value
Total2 = Cells(A + 1, 6).Value + Cells(A + 1, 7).Value
SumTotal = Total1 + Total2 + SumTotal
'MsgBox (Total1)
'MsgBox (Total2)
'MsgBox (SumTotal)
' Identifying Matched Rows
If SumTotal = 0 Then

'Variables of Marking Cells Declaration And Initialization
Dim M As Integer, N As Integer, P As Integer
M = A
N = B
'Declaration And Initialization Ends

'Row Marking
For J = 1 To RowCount
If Cells(M, N).Value = Cells(M + 1, B) Then
Cells(M + 1, 8).Value = "X"
Cells(M, 8).Value = "X"
M = M - 1
End If
Next J
'Row Marking Ends
End If
'Matched Row Identification Ends

Else
Total1 = 0
Total2 = 0
SumTotal = 0
End If
'Abs Value Check Ends

Else
Total1 = 0
Total2 = 0
SumTotal = 0
End If
'Currency Check Ends

' Cell Counter Increase
X = X + 1
A = A + 1
' Cell Counter Increase Ends

End If
'Empty Cell Check Ends

Next I
' Data Reconcilation Ends


' Cut Paste Procedure Starts

' Determining Where to Paste Reconciled Data
Columns("A:A").Select
    Selection.Find(What:="END", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=True, SearchFormat:=False).Activate
Dim D As Integer
D = ActiveCell.Row
' Determining Where to Paste Reconciled Data Ends

' Copy Paste Procedure Starts
For K = 2 To RowCount
If Cells(K, 8) = "X" Then
'MsgBox ("A" & K)
Range("A" & K & ":" & "G" & K).Select
Selection.Cut
Cells(D + 1, 1).Select
ActiveSheet.Paste
D = D + 1
End If
Next K
' Copy Paste Procedure Ends

'Delete Empty Rows
Dim S As Integer
S = 2
For K = 2 To RowCount
If Cells(S, 8) = "X" Then
Range("A" & S & ":" & "G" & S).Select
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Delete Shift:=xlUp
Else
S = S + 1
End If
Next K
'Delete Empty Rows Ends

Next Q
' Loop to run through all worksheets Ends

End Sub

--------------------------------------------------------------------

[abousetta]

Let me guess, the second half of the code is only being executed in the first sheet but not the rest

[Blue_kul]

Yups ... And I am unable to get through it !!

[Blue_kul]

here it is, first sheet shows the desired result but not working on rest of two sheets

Test File.xlsm

[Mordred]

Hi Blue_kul, can you provide a mock workbook with some non-sensitive data for us to work with?

[Mordred]

I think you need to declare what sheet is being worked on regarding your code. Try:

Private Sub CommandButton1_Click()

'Active WorkSheets Calculation
    Dim Ws_Count As Integer
    Dim Q As Integer

    Ws_Count = ActiveWorkbook.Worksheets.Count

    'Loop to run through all worksheets
    For Q = 1 To Ws_Count

        MsgBox ActiveWorkbook.Worksheets(Q).Name

        ' Sorting of Data
        Sheets(Q).Range("A1").Select
        Sheets(Q).Range(Selection, Selection.End(xlToRight)).Select
        ActiveWorkbook.Worksheets(Q).Sort.SortFields.Clear
        ActiveWorkbook.Worksheets(Q).Sort.SortFields.Add Key:=Range("B:B"), _
                                                         SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        ActiveWorkbook.Worksheets(Q).Sort.SortFields.Add Key:=Range("E:E"), _
                                                         SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        ActiveWorkbook.Worksheets(Q).Sort.SortFields.Add Key:=Range("F:F"), _
                                                         SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        ActiveWorkbook.Worksheets(Q).Sort.SortFields.Add Key:=Range("G:G"), _
                                                         SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        ActiveWorkbook.Worksheets(Q).Sort.SortFields.Add Key:=Range("D:D"), _
                                                         SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ActiveWorkbook.Worksheets(Q).Sort
            .SetRange Range("A:G")
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        ' Sorting Ends

        '------------Code works till here ------------

        ' Active Row Count
        'RowCount = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row - 1
        Dim RowCount As Long
        RowCount = Range("A1").CurrentRegion.Rows.Count
        'MsgBox "The number of rows is " & RowCount
        ' Row Count Ends

        'Cell Count Variable Declaration And Initialization
        Dim X As Integer, Y As Integer
        Dim A As Integer, B As Integer
        X = 2
        Y = 2
        A = 2
        B = 5
        'Declaration And Initialization Ends

        'Sum Variable Declaration And Initialization
        Dim Total1 As Double, Total2 As Double, TotalSum As Double
        Total1 = 0
        Total2 = 0
        SumTotal = 0
        'Declaration And Initialization Ends


        ' Data Reconcilation Start
        For I = 1 To RowCount

            ' Empty Cell Check
            If Sheets(Q).Cells(X, Y).Value <> "" Then

                ' Currency Check
                If Sheets(Q).Cells(X, Y).Value = Sheets(Q).Cells(X + 1, Y) Then

                    'Abs Total Check
                    If Sheets(Q).Cells(A, B).Value = Sheets(Q).Cells(A + 1, B) Then

                        Total1 = Sheets(Q).Cells(A, 6).Value + Sheets(Q).Cells(A, 7).Value
                        Total2 = Sheets(Q).Cells(A + 1, 6).Value + Sheets(Q).Cells(A + 1, 7).Value
                        SumTotal = Total1 + Total2 + SumTotal
                        'MsgBox (Total1)
                        'MsgBox (Total2)
                        'MsgBox (SumTotal)
                        ' Identifying Matched Rows
                        If SumTotal = 0 Then

                            'Variables of Marking Cells Declaration And Initialization
                            Dim M As Integer, N As Integer, P As Integer
                            M = A
                            N = B
                            'Declaration And Initialization Ends

                            'Row Marking
                            For J = 1 To RowCount
                                If Sheets(Q).Cells(M, N).Value = Sheets(Q).Cells(M + 1, B) Then
                                    Sheets(Q).Cells(M + 1, 8).Value = "X"
                                    Csheets(Q).ells(M, 8).Value = "X"
                                    M = M - 1
                                End If
                            Next J
                            'Row Marking Ends
                        End If
                        'Matched Row Identification Ends

                    Else
                        Total1 = 0
                        Total2 = 0
                        SumTotal = 0
                    End If
                    'Abs Value Check Ends

                Else
                    Total1 = 0
                    Total2 = 0
                    SumTotal = 0
                End If
                'Currency Check Ends

                ' Cell Counter Increase
                X = X + 1
                A = A + 1
                ' Cell Counter Increase Ends

            End If
            'Empty Cell Check Ends

        Next I
        ' Data Reconcilation Ends


        ' Cut Paste Procedure Starts

        ' Determining Where to Paste Reconciled Data
        Sheets(Q).Columns("A:A").Select
        Selection.Find(What:="END", After:=ActiveCell, LookIn:=xlFormulas, _
                       LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                       MatchCase:=True, SearchFormat:=False).Activate
        Dim D As Integer
        D = ActiveCell.Row
        ' Determining Where to Paste Reconciled Data Ends

        ' Copy Paste Procedure Starts
        For K = 2 To RowCount
            If Sheets(Q).Cells(K, 8) = "X" Then
                'MsgBox ("A" & K)
                Sheets(Q).Range("A" & K & ":" & "G" & K).Select
                Selection.Cut
                Sheets(Q).Cells(D + 1, 1).Select
                ActiveSheet.Paste
                D = D + 1
            End If
        Next K
        ' Copy Paste Procedure Ends

        'Delete Empty Rows
        Dim S As Integer
        S = 2
        For K = 2 To RowCount
            If Sheets(Q).Cells(S, 8) = "X" Then
                Sheets(Q).Range("A" & S & ":" & "G" & S).Select
                ActiveCell.Rows("1:1").EntireRow.Select
                Selection.Delete Shift:=xlUp
            Else
                S = S + 1
            End If
        Next K
        'Delete Empty Rows Ends

    Next Q
    ' Loop to run through all worksheets Ends

End Sub

and let us know how it goes.

[Blue_kul]

Nopes ... no luck !! i think I am missing something very stupid .. !!

[abousetta]

From a quick look at your code, you are looping correctly through the worksheets, but the problem is that the focus of the second part of the code never moved from the first sheet. The way I would normally do this is to use:

 With worksheet(Q)

' some code

End with

but that also means that you have to put a period before every range [e.g. .Range("A1") or .Cells(1, 1)].

Or you can activate each worksheet at the begining of the loop:

'Loop to run through all worksheets
For Q = 1 To Ws_Count

ActiveWorkbook.Worksheets(Q).Activate

abousetta

[Blue_kul]

From a quick look at your code, you are looping correctly through the worksheets, but the problem is that the focus of the second part of the code never moved from the first sheet. The way I would normally do this is to use:

 With worksheet(Q)

' some code

End with

but that also means that you have to put a period before every range [e.g. .Range("A1") or .Cells(1, 1)].

Or you can activate each worksheet at the begining of the loop:

'Loop to run through all worksheets
For Q = 1 To Ws_Count

ActiveWorkbook.Worksheets(Q).Activate

abousetta

I tried the second option but still no luck, only data gets sorted but rest of action is missing.
If possible can you please evaluate my worksheet, attached in earlier post, for any issue with properties or something minute I am missing,

[Blue_kul]

Tried the code, separately on each sheet and is working fine, but giving me error, when tried to run for sheet 3, its says, script out of range, though activeworksheet count is rightly captured as 3.

[Blue_kul]

And now when i tried to loop in worksheets by using activate command, it throws me error at the last sheet always, can you spot any issue with a loop/counter, coz i have tried adding/deleting sheets but at last counter always errors out.

Error Message:
Capture.jpg

When I tried to debug using run to cursor, it points to
Capture2.JPG

[Blue_kul]

Any one please ? I am still stuck at this and it wont loop through all my worksheets !! Thanx

[Andrew-R]

Activating each sheet is slow and makes the screen jump about (unless you set Application.ScreenUpdating=False), it's best to use something along the lines of:

Sub ExampleLoop()

Dim wshWorkSheetLoop As WorkSheet

For Each wshWorkSheetLoop in ActiveWorkBook.Sheets

  With wshWorkSheetLoop

      'Your code goes in here
      'With periods in front of any range objects you're accessing

      Msgbox .Range("A1").Value 'For example

  End With

Next wshWorkSheetLoop

End Sub

[abousetta]

Hi Andrew,

I agree that activating, selecting, etc. is a waste of time but it is a valid option especially for a novice who might not be able to spot every range object (especially if the code is snippets borrowed from online pieces of code). It took me some time and effort to learn how to improve code efficiency and it's not always clear which lines of code can be/ should be ommited or condensed.

[Andrew-R]

Can you post the code you're now using, please, and I'll have a look.

[Blue_kul]

Finally, I got it working .. thanks all for your support !!!

How do I mark a thread to resolved/solved ?

[Blue_kul]

I looped all my worksheets using:

Ws_Count = ActiveWorkbook.Worksheets.Count
'Loop to run through all worksheets
For W = 1 To Ws_Count
Sheets(W).Activate
..
..
..
Activeworkbook.activesheet.cells.(...).value
..
..

[abousetta]

Hi,

Glad it all worked out. You can mark it as [SOLVED] by going to the original post (#1) --> Go Advanced --> and change the prefix to [SOLVED]. Details should be avaialble in the forum rules.

Best of luck.

abousetta