Warm tip: This article is reproduced from serverfault.com, please click

How to sort tables across multiple worksheets?

发布于 2020-11-28 01:50:51

I am trying to sort 3 tables across 3 worksheets. I have made use of the Macro Recording tool and came up with these codes. However I can't get it running. Would highly appreciate any help given.

ps: How to do I post the codes properly in this forum? The code I posted below seems like a mess.

Sub SortTable_Click()
Dim sheetList
sheetList = Array("AAA", "BBB", "CCC")
Dim sheetName
For Each sheetName In sheetList
SortSheet ThisWorkbook.Sheets(sheetName)
Next sheetName
    
Sub SortSheet()
ActiveWorkbook.sheetName.AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.sheetName.AutoFilter.Sort.SortFields.Add2 _
Key:=Range("A3"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.sheetName.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Questioner
Deniouz
Viewed
0
Variatus 2020-11-30 11:03:29

Extended answer

The code below includes procedures to call the sorter selected above. The original code is adapted but not changed (meaning it works in the same manner but no longer as a stand-alone, nor will the procedure in my above answer work with the code below. Paste the code below in a standard code module. Then follow the further instructions below its end.

Option Explicit

Const CmdName       As String = "CmdSort"           ' rename to suit
Const LbxName       As String = "LbxSort"

Sub SortSelector()
    ' 126

    ' list tab names to be excluded from the list here, comma-separated
    Const Excl      As String = "Sheet17,Sheet25"
    Const MaxHeight As Single = 330     ' adjust to suit
    Const RowHeight As Single = 14.9    ' adjust to suit
    ' RowHeight may be different depending upon your default font
    
    
    Dim Control As OLEObject
    Dim Command As MSForms.CommandButton
    Dim ListBox As MSForms.ListBox
    Dim i       As Integer              ' loop counter: index
    Dim n       As Integer              ' number of list entries
    Dim Tmp     As Variant
    
    With ActiveSheet.OLEObjects
        DeleteControls                  ' delete pre-existing
        Set Control = .Add(ClassType:="Forms.ListBox.1", _
                           Link:=False, DisplayAsIcon:=False, _
                           Left:=200, Top:=40, _
                           Width:=100, Height:=RowHeight)
                           ' manage Left, Top, Width and max Height here
    End With
    With Control
        Set ListBox = .Object
        With ListBox
            .Name = LbxName
            For i = 1 To Worksheets.Count
                Tmp = Worksheets(i).Name
                If InStr(1, "," & Excl & ",", "," & Tmp & ",", vbTextCompare) = 0 Then
                    .AddItem Tmp
                    n = n + 1
                End If
            Next i
            If n Then
                n = n + 1
                .AddItem "All"
                .MultiSelect = fmMultiSelectMulti
                .BackColor = 13431551           ' change ListBox color here

                Set Command = ActiveSheet.OLEObjects.Add( _
                                 ClassType:="Forms.CommandButton.1", _
                                 Link:=False, DisplayAsIcon:=False, _
                                 Left:=Control.Left, Top:=Control.Top - 27, _
                                 Width:=Control.Width, Height:=24).Object
                With Command
                    .Name = CmdName
                    .Caption = "Sort now"
                    .BackColor = 9359529    ' change Button colour here
                    .Font.Bold = True
                    .TakeFocusOnClick = False
                End With
            End If
        End With
    End With
    
    If n Then
        Tmp = Application.WorksheetFunction.Min(n * RowHeight, MaxHeight)
        Control.Height = Tmp
        Control.Activate
        With ListBox
            .ListIndex = .ListCount - 1
            .Selected(.ListIndex) = True
        End With
    End If
End Sub

Sub RunDeleteControls()
    ' 126
    ' use this procedure to delete stray controls created
    ' by this project and left behind in a crash
    
    DeleteControls
End Sub

Sub DeleteControls(Optional ByVal Hide As Boolean)
    ' 126
    ' delete or hide pre-existing controls
    
    ' ==========================================================
    ' This procedure can also be run indepedent from this project
    ' (place the cursor in the sub 'RunDeleteControls` and press F5)
    ' ==========================================================
    
    Dim Arr     As Variant
    Dim i       As Long
    
    Arr = Array(CmdName, LbxName)
    With ActiveSheet.OLEObjects
        On Error Resume Next
        For i = 0 To UBound(Arr)
            With .Item(Arr(i))
                .Visible = False
                If Not Hide Then .Delete
            End With
        Next i
    End With
    Err.Clear
End Sub

Sub SetTabSelection(Lbx As MSForms.ListBox)
    ' 126

    Static Disabled As Boolean          ' disable control events
    Dim All         As Integer          ' ListIndex of "All" (0-based)
    Dim i           As Integer          ' loop counter: ListIndex
    Dim n           As Integer
    
    If Not Disabled Then
        With Lbx
            Disabled = True
            All = .ListCount - 1
            If .ListIndex = All Then
                If .Selected(All) Then
                    For i = 0 To .ListCount - 2
                        .Selected(i) = False
                    Next i
                End If
            Else
                For i = 0 To .ListCount - 2
                    n = n + .Selected(i)
                Next i
                If Abs(n) = All Then
                    For i = 0 To .ListCount - 2
                        .Selected(i) = False
                    Next i
                End If
                .Selected(All) = (Abs(n) = All)
            End If
            Disabled = False
        End With
    End If
End Sub

Sub SortSelectedTables(Lbx As MSForms.ListBox)
    ' 126

    Dim TabList()       As String
    Dim All             As Boolean
    Dim n               As Integer              ' count of selected tabs
    Dim i               As Long                 ' loop counter: Lbx index
    
    With Lbx
        All = .Selected(.ListCount - 1)
        ReDim TabList(1 To .ListCount)
        For i = 0 To .ListCount - 2
            If (.Selected(i) Or All) Then
                n = n + 1
                TabList(n) = .List(i)
            End If
        Next i
    End With
    If n Then
        ReDim Preserve TabList(1 To n)
         SortTables TabList
        i = 0
    Else
        i = MsgBox("No worksheets were selected for sorting." & vbCr & _
                   "Exit without any action?", _
                   vbYesNo, "Cancel sorting")
    End If
    
    If i <> vbNo Then DeleteControls True
    ' Controls are only hidden at this point.
    ' They will be deleted when the tab is deactivated.
End Sub

Private Sub SortTables(TabList() As String)
    ' 126 - Nov 30, 2020
    
    Dim i               As Integer          ' TbList index
    Dim Tbl             As ListObject       ' loop object: Table
    
    For i = LBound(TabList) To UBound(TabList)
        On Error Resume Next
        ' an error will occur if the table doesn't exist
        Set Tbl = Worksheets(TabList(i)).ListObjects(1)
        If Err = 0 Then
            On Error GoTo 0                 ' stop on further errors
            With Tbl.Sort
                .SortFields.Clear
                .SortFields.Add2 Key:=Tbl.DataBodyRange.Columns(1), _
                                 SortOn:=xlSortOnValues, _
                                 Order:=xlAscending, _
                                 DataOption:=xlSortNormal
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        End If
    Next i
End Sub

To run this code run the procedure SortSelector. Perhaps create a button for it or a shortcut. the code will create a list box on the ActiveSheet. The box lists all sheets in the workbook except those specified in the constant Const Excl As String = "Sheet17,Sheet25". Change the list to suit your needs. Avoid blanks that aren't part of a sheet name. You can also adjust the maximum size of the list box, its row height and, if you dive further into the code, control colours. Please read all comments.

You can select one, several, all or none of the sheets. Click on the Sort now button to sort the selected sheets. De-selecting all is paramount to Cancel. Unfortunately, all of the above is enabled only by the procedures below which must be pasted into the code module of the worksheet on which you want the action.

Private Sub CmdSort_Click()
    ' 126
    SortSelectedTables LbxSort
End Sub

Private Sub LbxSort_Change()
    ' 126
    SetTabSelection LbxSort
End Sub

Private Sub Worksheet_Deactivate()
    ' 126
    DeleteControls
End Sub

The code is designed to act on the ActiveSheet. Of course, that could be any sheet of your workbook. The 3 event procedures could be copied to the code modules of all the tabs in your workbook. If you do that you can use the feature on all the tabs in your workbook. If you leave some out, look for the procedure RunDeleteControls in the standard code module which will remove the dysfunctional controls. They can also be deleted manually. Just remember, the controls created by SortSelector will be animated by the 3 event procedures. Without them they will be unresponsive.


Finally, a word about why it took so long. In essence the code provides the functionality of a user form - without a user form and the extra clicks that entails. I have never programmed like that before, nor have I seen such work done by others. Please share your experience here.