Need VBA Help - Organizing Data (Already in Columns)...

L

Lidsavr

Active Member
Joined
Jan 10, 2008
Messages
330
I am running Excel 2010.

I have a data set that is already organized into columns (two columns per set) - Please see the attached file by clicking on the link below!

I need to organize the columns using the numbers at the top of the row from largest to smallest. The column immediately to the right of the numbered column is part of the numbered column (they must stay together!).

Here is an example (Note: I am having problems getting the picture to view in this post, so you can download it if you wish using the following link:

https://drive.google.com/file/d/0B8ZFmctoHTEBRGtMMEU5eFo4M0k/view?usp=sharing

Here is a link to the actual file if you want to view it in full:

https://docs.google.com/spreadsheets/d/1DB_YEaZYD6ZRkIqZgVsqm3Q7aIMl2oBj-Ryu0ozTGxg/edit?usp=sharing

Details:
The top row contains the number to sort. In the instance above, 17 is the largest number. There are two other columns with the number 17 somewhere in the dataset. I need to find each one and move it and the column immediately to the right to the left so it is immediately to the right of the first column 17. Then I need to do the same thing with all column 16s, then column 15s, etc.

To add to my problem, sometimes there are only two columns with the same number, sometimes there are three and on rare occasions there is only one column with the its own number.

I hope that I have explained my problem adequately. I have tried Find statements, Find Next Statements, For...Next statements and For I statements. I am obviously doing something wrong, so I turn to the board for help. Will someone help me come up with the code to organize all the columns in order?

My data recently changed, I used to only have two sets of the same number. The code below work to first organize the columns together by number (17,17,15,15,10,10,9,9,1,1,0,0,etc.) and then organizing the second subroutine organized them in order (17,17,16,16,15,15,15,etc.). Adding the third column is what has thrown me for a loop.

Last thought before you view the code, I know my code is bloated and fat; however, I justify it be saying that I am self-taught (and still learning with the help of this board and a lot of books). If you know of a way that works with less code, I am open to learning.

Thanks for helping!

Charles (Lidsavr)

Here is the code:

Code: 
Private Sub Organize_Columns()
    Dim seN As Variant
    Dim nxT As Variant
    Dim rnG1 As Range
    
    Range("A1").Select
'   Moves the ActiveCell for columns to the right
    ActiveCell.Offset(0, 4).Select
    Do
        Set seN = ActiveCell
        If ActiveCell.Offset(0, 2).Value <> seN Then 'looks two cell to the right and determines if the value is not equal to the seN variable
            Set rnG1 = ActiveCell 'sets the ActiveCell as variable rnG1
            Cells.Find(What:=seN, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , SearchFormat:=False).Activate 'looks for the next seN variable in the dataset
            ActiveCell.EntireColumn.Select 'selects the entire column
            Range(Selection, Selection.Offset(0, 1)).Select 'also selects the next column
            Selection.Cut 'cuts the column
            rnG1.Select 'selects the rnG1 variable
            Selection.Offset(0, 2).Select 'moves the ActiveCell two columns to the right
            ActiveCell.EntireColumn.Select 'selects the column, inserts the clipboard, pushing the original data to the right.
            Selection.Insert Shift:=xlToRight
            ActiveCell.Offset(0, 2).Select 'moves the ActiveCell two cells to the right to begin the next search.
        Else
            If ActiveCell.Offset(0, -1).Value = "" Then
                Call Organize_Columns2
            End If
            ActiveCell.Offset(0, 4).Select
        End If
    Loop Until ActiveCell.Offset(3, 0).Value = "Run_ID" 'Loops the subroutine until conditions are met.
Call Organize_Columns2
End
End Sub
Private Sub Organize_Columns2()
    Dim rng2 As Range
    Dim rng3 As Range
    Dim mX1 As Variant
    Dim mX2 As Variant
    Dim mX3 As Variant
    Dim mX4 As Variant
    Dim mX5 As Variant
    Dim mX6 As Variant
    Dim mX7 As Variant
    Dim mX8 As Variant
    Dim mX9 As Variant
    Dim mX10 As Variant
    Dim mX11 As Variant
    Dim mX12 As Variant
    Dim mX13 As Variant
    Dim mX14 As Variant
    Dim mX15 As Variant
    
    Sheets("DataLog").Select
'   Sets gives variables values (numbers).
    Range("E1:CA1").Select
    Set rng2 = Selection
    mX1 = WorksheetFunction.Max(rng2)
    mX2 = mX1 - 1
    mX3 = mX1 - 2
    mX4 = mX1 - 3
    mX5 = mX1 - 4
    mX6 = mX1 - 5
    mX7 = mX1 - 6
    mX8 = mX1 - 7
    mX9 = mX1 - 8
    mX10 = mX1 - 9
    mX11 = mX1 - 10
    mX12 = mX1 - 11
    mX13 = mX1 - 12
    mX14 = mX1 - 13
    mX15 = mX1 - 14
    mX16 = mX1 - 15
    mX17 = mX1 - 16
    
    On Error Resume Next
'   Starts organizing columns so they are in order starting with the largest number
    Range("E1").Select
    Set rng3 = Selection
    If mX1 = rng3.Value Then
        If mX1 < 0 Then
            Application.CutCopyMode = False
            Range("A1").Select
            On Error GoTo 0
            End
        End If
        ActiveCell.Offset(0, 4).Select
    Else
        Cells.Find(What:=mX1, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False).Activate
        ActiveCell.EntireColumn.Select
        Range(Selection, Selection.Offset(0, 3)).Select
        Selection.Cut
        rng3.Select
        Selection.Insert Shift:=xlToRight
        ActiveCell.Select
        If ActiveCell.Value = mX1 Then
            ActiveCell.Offset(0, 4).Select
        End If
    End If
   
    Set rng3 = Selection
    If mX2 < 0 Then
        Application.CutCopyMode = False
        Range("A1").Select
        On Error GoTo 0
        End
    End If
    If mX2 = rng3.Value Then
        ActiveCell.Offset(0, 4).Select
    Else
        Cells.Find(What:=mX2, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False).Activate
        If ActiveCell.Offset(0, 2) <> mX2 Then
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 1)).Select
            Selection.Copy
            Selection.Offset(0, 2).Select
            Selection.Insert Shift:=xlToRight
            Application.CutCopyMode = False
            ActiveCell.Select
            ActiveCell.Offset(0, -2).Select
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 3)).Select
            Selection.Cut
            Range("E1").Select
            Cells.Find(What:=mX1, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , SearchFormat:=False).Activate
            ActiveCell.Offset(0, 4).Select
            Selection.Insert Shift:=xlToRight
            ActiveCell.Offset(0, 4).Select
            GoTo SECT_MX3
        End If
        ActiveCell.EntireColumn.Select
        Range(Selection, Selection.Offset(0, 3)).Select
        Selection.Cut
        rng3.Select
        Selection.Insert Shift:=xlToRight
        If ActiveCell.Value = mX2 Then
            ActiveCell.Offset(0, 4).Select
        End If
    End If
    
SECT_MX3:
    Set rng3 = Selection
    If mX3 < 0 Then
        Application.CutCopyMode = False
        Range("A1").Select
        On Error GoTo 0
        End
    End If
    If mX3 = rng3.Value Then
        ActiveCell.Offset(0, 4).Select
    Else
        Cells.Find(What:=mX3, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False).Activate
        If ActiveCell.Offset(0, 2) <> mX3 Then
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 1)).Select
            Selection.Copy
            Selection.Offset(0, 2).Select
            Selection.Insert Shift:=xlToRight
            Application.CutCopyMode = False
            ActiveCell.Select
            ActiveCell.Offset(0, -2).Select
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 3)).Select
            Selection.Cut
            Range("E1").Select
            Cells.Find(What:=mX2, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , SearchFormat:=False).Activate
            ActiveCell.Offset(0, 4).Select
            Selection.Insert Shift:=xlToRight
            ActiveCell.Offset(0, 4).Select
            GoTo SECT_MX4
        End If
        ActiveCell.EntireColumn.Select
        Range(Selection, Selection.Offset(0, 3)).Select
        Selection.Cut
        rng3.Select
        Selection.Insert Shift:=xlToRight
        If ActiveCell.Value = mX3 Then
            ActiveCell.Offset(0, 4).Select
        End If
    End If
    
SECT_MX4:
    Set rng3 = Selection
    If mX4 < 0 Then
        Application.CutCopyMode = False
        Range("A1").Select
        On Error GoTo 0
        End
    End If
    If mX4 = rng3.Value Then
        ActiveCell.Offset(0, 4).Select
    Else
        Cells.Find(What:=mX4, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False).Activate
        If ActiveCell.Offset(0, 2) <> mX4 Then
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 1)).Select
            Selection.Copy
            Selection.Offset(0, 2).Select
            Selection.Insert Shift:=xlToRight
            Application.CutCopyMode = False
            ActiveCell.Select
            ActiveCell.Offset(0, -2).Select
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 3)).Select
            Selection.Cut
            Range("E1").Select
            Cells.Find(What:=mX3, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , SearchFormat:=False).Activate
            ActiveCell.Offset(0, 4).Select
            Selection.Insert Shift:=xlToRight
            ActiveCell.Offset(0, 4).Select
            GoTo SECT_MX5
        End If
        ActiveCell.EntireColumn.Select
        Range(Selection, Selection.Offset(0, 3)).Select
        Selection.Cut
        rng3.Select
        Selection.Insert Shift:=xlToRight
        If ActiveCell.Value = mX4 Then
            ActiveCell.Offset(0, 4).Select
        End If
    End If
    
SECT_MX5:
    Set rng3 = Selection
    If mX5 < 0 Then
        Application.CutCopyMode = False
        Range("A1").Select
        On Error GoTo 0
        End
    End If
    If mX5 = rng3.Value Then
        ActiveCell.Offset(0, 4).Select
    Else
        Cells.Find(What:=mX5, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False).Activate
        If ActiveCell.Offset(0, 2) <> mX5 Then
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 1)).Select
            Selection.Copy
            Selection.Offset(0, 2).Select
            Selection.Insert Shift:=xlToRight
            Application.CutCopyMode = False
            ActiveCell.Select
            ActiveCell.Offset(0, -2).Select
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 3)).Select
            Selection.Cut
            Range("E1").Select
            Cells.Find(What:=mX4, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , SearchFormat:=False).Activate
            ActiveCell.Offset(0, 4).Select
            Selection.Insert Shift:=xlToRight
            ActiveCell.Offset(0, 4).Select
            GoTo SECT_MX6
        End If
        ActiveCell.EntireColumn.Select
        Range(Selection, Selection.Offset(0, 3)).Select
        Selection.Cut
        rng3.Select
        Selection.Insert Shift:=xlToRight
        If ActiveCell.Value = mX5 Then
            ActiveCell.Offset(0, 4).Select
        End If
    End If

SECT_MX6:
    Set rng3 = Selection
    If mX6 < 0 Then
        Application.CutCopyMode = False
        Range("A1").Select
        On Error GoTo 0
        End
    End If
    If mX6 = rng3.Value Then
        ActiveCell.Offset(0, 4).Select
    Else
        Cells.Find(What:=mX6, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False).Activate
        If ActiveCell.Offset(0, 2) <> mX6 Then
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 1)).Select
            Selection.Copy
            Selection.Offset(0, 2).Select
            Selection.Insert Shift:=xlToRight
            Application.CutCopyMode = False
            ActiveCell.Select
            ActiveCell.Offset(0, -2).Select
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 3)).Select
            Selection.Cut
            Range("E1").Select
            Cells.Find(What:=mX5, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , SearchFormat:=False).Activate
            ActiveCell.Offset(0, 4).Select
            Selection.Insert Shift:=xlToRight
            ActiveCell.Offset(0, 4).Select
            GoTo SECT_MX7
        End If
        ActiveCell.EntireColumn.Select
        Range(Selection, Selection.Offset(0, 3)).Select
        Selection.Cut
        rng3.Select
        Selection.Insert Shift:=xlToRight
        If ActiveCell.Value = mX6 Then
            ActiveCell.Offset(0, 4).Select
        End If
    End If
    
SECT_MX7:
    Set rng3 = Selection
    If mX7 < 0 Then
        Application.CutCopyMode = False
        Range("A1").Select
        On Error GoTo 0
        End
    End If
    If mX7 = rng3.Value Then
        ActiveCell.Offset(0, 4).Select
    Else
        Cells.Find(What:=mX7, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False).Activate
        If ActiveCell.Offset(0, 2) <> mX7 Then
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 1)).Select
            Selection.Copy
            Selection.Offset(0, 2).Select
            Selection.Insert Shift:=xlToRight
            Application.CutCopyMode = False
            ActiveCell.Select
            ActiveCell.Offset(0, -2).Select
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 3)).Select
            Selection.Cut
            Range("E1").Select
            Cells.Find(What:=mX6, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , SearchFormat:=False).Activate
            ActiveCell.Offset(0, 4).Select
            Selection.Insert Shift:=xlToRight
            ActiveCell.Offset(0, 4).Select
            GoTo SECT_MX8
        End If
        ActiveCell.EntireColumn.Select
        Range(Selection, Selection.Offset(0, 3)).Select
        Selection.Cut
        rng3.Select
        Selection.Insert Shift:=xlToRight
        If ActiveCell.Value = mX7 Then
            ActiveCell.Offset(0, 4).Select
        End If
    End If

SECT_MX8:
    Set rng3 = Selection
    If mX8 < 0 Then
        Application.CutCopyMode = False
        Range("A1").Select
        On Error GoTo 0
        End
    End If
    If mX8 = rng3.Value Then
        ActiveCell.Offset(0, 4).Select
    Else
        Cells.Find(What:=mX8, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False).Activate
        If ActiveCell.Offset(0, 2) <> mX8 Then
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 1)).Select
            Selection.Copy
            Selection.Offset(0, 2).Select
            Selection.Insert Shift:=xlToRight
            Application.CutCopyMode = False
            ActiveCell.Select
            ActiveCell.Offset(0, -2).Select
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 3)).Select
            Selection.Cut
            Range("E1").Select
            Cells.Find(What:=mX7, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , SearchFormat:=False).Activate
            ActiveCell.Offset(0, 4).Select
            Selection.Insert Shift:=xlToRight
            ActiveCell.Offset(0, 4).Select
            GoTo SECT_MX9
        End If
        ActiveCell.EntireColumn.Select
        Range(Selection, Selection.Offset(0, 3)).Select
        Selection.Cut
        rng3.Select
        Selection.Insert Shift:=xlToRight
        If ActiveCell.Value = mX8 Then
            ActiveCell.Offset(0, 4).Select
        End If
    End If

SECT_MX9:
    Set rng3 = Selection
    If mX9 < 0 Then
        Application.CutCopyMode = False
        Range("A1").Select
        On Error GoTo 0
        End
    End If
    If mX9 = rng3.Value Then
        ActiveCell.Offset(0, 4).Select
    Else
        Cells.Find(What:=mX9, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False).Activate
        If ActiveCell.Offset(0, 2) <> mX9 Then
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 1)).Select
            Selection.Copy
            Selection.Offset(0, 2).Select
            Selection.Insert Shift:=xlToRight
            Application.CutCopyMode = False
            ActiveCell.Select
            ActiveCell.Offset(0, -2).Select
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 3)).Select
            Selection.Cut
            Range("E1").Select
            Cells.Find(What:=mX8, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , SearchFormat:=False).Activate
            ActiveCell.Offset(0, 4).Select
            Selection.Insert Shift:=xlToRight
            ActiveCell.Offset(0, 4).Select
            GoTo SECT_MX10
        End If
        ActiveCell.EntireColumn.Select
        Range(Selection, Selection.Offset(0, 3)).Select
        Selection.Cut
        rng3.Select
        Selection.Insert Shift:=xlToRight
        If ActiveCell.Value = mX9 Then
            ActiveCell.Offset(0, 4).Select
        End If
    End If
    
SECT_MX10:
    Set rng3 = Selection
    If mX10 < 0 Then
        Application.CutCopyMode = False
        Range("A1").Select
        On Error GoTo 0
        End
    End If
    If mX10 = rng3.Value Then
        ActiveCell.Offset(0, 4).Select
    Else
        Cells.Find(What:=mX10, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False).Activate
        If ActiveCell.Offset(0, 2) <> mX10 Then
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 1)).Select
            Selection.Copy
            Selection.Offset(0, 2).Select
            Selection.Insert Shift:=xlToRight
            Application.CutCopyMode = False
            ActiveCell.Select
            ActiveCell.Offset(0, -2).Select
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 3)).Select
            Selection.Cut
            Range("E1").Select
            Cells.Find(What:=mX9, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , SearchFormat:=False).Activate
            ActiveCell.Offset(0, 4).Select
            Selection.Insert Shift:=xlToRight
            ActiveCell.Offset(0, 4).Select
            GoTo SECT_MX11
        End If
        ActiveCell.EntireColumn.Select
        Range(Selection, Selection.Offset(0, 3)).Select
        Selection.Cut
        rng3.Select
        Selection.Insert Shift:=xlToRight
        If ActiveCell.Value = mX10 Then
            ActiveCell.Offset(0, 4).Select
        End If
    End If
    
SECT_MX11:
    Set rng3 = Selection
    If mX11 < 0 Then
        Application.CutCopyMode = False
        Range("A1").Select
        On Error GoTo 0
        End
    End If
    If mX11 = rng3.Value Then
        ActiveCell.Offset(0, 4).Select
    Else
        Cells.Find(What:=mX11, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False).Activate
        If ActiveCell.Offset(0, 2) <> mX11 Then
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 1)).Select
            Selection.Copy
            Selection.Offset(0, 2).Select
            Selection.Insert Shift:=xlToRight
            Application.CutCopyMode = False
            ActiveCell.Select
            ActiveCell.Offset(0, -2).Select
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 3)).Select
            Selection.Cut
            Range("E1").Select
            Cells.Find(What:=mX10, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , SearchFormat:=False).Activate
            ActiveCell.Offset(0, 4).Select
            Selection.Insert Shift:=xlToRight
            ActiveCell.Offset(0, 4).Select
            GoTo SECT_MX12
        End If
        ActiveCell.EntireColumn.Select
        Range(Selection, Selection.Offset(0, 3)).Select
        Selection.Cut
        rng3.Select
        Selection.Insert Shift:=xlToRight
        If ActiveCell.Value = mX11 Then
            ActiveCell.Offset(0, 4).Select
        End If
    End If
    
SECT_MX12:
    Set rng3 = Selection
    If mX12 < 0 Then
        Application.CutCopyMode = False
        Range("A1").Select
        On Error GoTo 0
        End
    End If
    If mX12 = rng3.Value Then
        ActiveCell.Offset(0, 4).Select
    Else
        Cells.Find(What:=mX12, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False).Activate
        If ActiveCell.Offset(0, 2) <> mX12 Then
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 1)).Select
            Selection.Copy
            Selection.Offset(0, 2).Select
            Selection.Insert Shift:=xlToRight
            Application.CutCopyMode = False
            ActiveCell.Select
            ActiveCell.Offset(0, -2).Select
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 3)).Select
            Selection.Cut
            Range("E1").Select
            Cells.Find(What:=mX11, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , SearchFormat:=False).Activate
            ActiveCell.Offset(0, 4).Select
            Selection.Insert Shift:=xlToRight
            ActiveCell.Offset(0, 4).Select
            GoTo SECT_MX13
        End If
        ActiveCell.EntireColumn.Select
        Range(Selection, Selection.Offset(0, 3)).Select
        Selection.Cut
        rng3.Select
        Selection.Insert Shift:=xlToRight
        If ActiveCell.Value = mX12 Then
            ActiveCell.Offset(0, 4).Select
        End If
    End If
    
SECT_MX13:
    Set rng3 = Selection
    If mX13 < 0 Then
        Application.CutCopyMode = False
        Range("A1").Select
        On Error GoTo 0
        End
    End If
    If mX13 = rng3.Value Then
        ActiveCell.Offset(0, 4).Select
    Else
        Cells.Find(What:=mX13, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False).Activate
        If ActiveCell.Offset(0, 2) <> mX13 Then
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 1)).Select
            Selection.Copy
            Selection.Offset(0, 2).Select
            Selection.Insert Shift:=xlToRight
            Application.CutCopyMode = False
            ActiveCell.Select
            ActiveCell.Offset(0, -2).Select
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 3)).Select
            Selection.Cut
            Range("E1").Select
            Cells.Find(What:=mX12, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , SearchFormat:=False).Activate
            ActiveCell.Offset(0, 4).Select
            Selection.Insert Shift:=xlToRight
            ActiveCell.Offset(0, 4).Select
            GoTo SECT_MX14
        End If
        ActiveCell.EntireColumn.Select
        Range(Selection, Selection.Offset(0, 3)).Select
        Selection.Cut
        rng3.Select
        Selection.Insert Shift:=xlToRight
        If ActiveCell.Value = mX13 Then
            ActiveCell.Offset(0, 4).Select
        End If
    End If
    
SECT_MX14:
    Set rng3 = Selection
    If mX14 < 0 Then
        Application.CutCopyMode = False
        Range("A1").Select
        On Error GoTo 0
        End
    End If
    If mX14 = rng3.Value Then
        ActiveCell.Offset(0, 4).Select
    Else
        Cells.Find(What:=mX14, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False).Activate
        If ActiveCell.Offset(0, 2) <> mX14 Then
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 1)).Select
            Selection.Copy
            Selection.Offset(0, 2).Select
            Selection.Insert Shift:=xlToRight
            Application.CutCopyMode = False
            ActiveCell.Select
            ActiveCell.Offset(0, -2).Select
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 3)).Select
            Selection.Cut
            Range("E1").Select
            Cells.Find(What:=mX13, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , SearchFormat:=False).Activate
            ActiveCell.Offset(0, 4).Select
            Selection.Insert Shift:=xlToRight
            ActiveCell.Offset(0, 4).Select
            GoTo SECT_MX15
        End If
        ActiveCell.EntireColumn.Select
        Range(Selection, Selection.Offset(0, 3)).Select
        Selection.Cut
        rng3.Select
        Selection.Insert Shift:=xlToRight
        If ActiveCell.Value = mX14 Then
            ActiveCell.Offset(0, 4).Select
        End If
    End If
    
SECT_MX15:
    Set rng3 = Selection
    If mX15 < 0 Then
        Application.CutCopyMode = False
        Range("A1").Select
        On Error GoTo 0
        End
    End If
    If mX15 = rng3.Value Then
        ActiveCell.Offset(0, 4).Select
    Else
        Cells.Find(What:=mX15, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False).Activate
        If ActiveCell.Offset(0, 2) <> mX15 Then
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 1)).Select
            Selection.Copy
            Selection.Offset(0, 2).Select
            Selection.Insert Shift:=xlToRight
            Application.CutCopyMode = False
            ActiveCell.Select
            ActiveCell.Offset(0, -2).Select
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 3)).Select
            Selection.Cut
            Range("E1").Select
            Cells.Find(What:=mX14, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , SearchFormat:=False).Activate
            ActiveCell.Offset(0, 4).Select
            Selection.Insert Shift:=xlToRight
            ActiveCell.Offset(0, 4).Select
            GoTo SECT_MX16
        End If
        ActiveCell.EntireColumn.Select
        Range(Selection, Selection.Offset(0, 3)).Select
        Selection.Cut
        rng3.Select
        Selection.Insert Shift:=xlToRight
        If ActiveCell.Value = mX15 Then
            ActiveCell.Offset(0, 4).Select
        End If
    End If
    
SECT_MX16:
    Set rng3 = Selection
    If mX16 < 0 Then
        Application.CutCopyMode = False
        Range("A1").Select
        On Error GoTo 0
        End
    End If
    If mX16 = rng3.Value Then
        ActiveCell.Offset(0, 4).Select
    Else
        Cells.Find(What:=mX16, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False).Activate
        If ActiveCell.Offset(0, 2) <> mX16 Then
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 1)).Select
            Selection.Copy
            Selection.Offset(0, 2).Select
            Selection.Insert Shift:=xlToRight
            Application.CutCopyMode = False
            ActiveCell.Select
            ActiveCell.Offset(0, -2).Select
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 3)).Select
            Selection.Cut
            Range("E1").Select
            Cells.Find(What:=mX15, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , SearchFormat:=False).Activate
            ActiveCell.Offset(0, 4).Select
            Selection.Insert Shift:=xlToRight
            ActiveCell.Offset(0, 4).Select
            GoTo SECT_MX17
        End If
        ActiveCell.EntireColumn.Select
        Range(Selection, Selection.Offset(0, 3)).Select
        Selection.Cut
        rng3.Select
        Selection.Insert Shift:=xlToRight
        If ActiveCell.Value = mX16 Then
            ActiveCell.Offset(0, 4).Select
        End If
    End If
    
SECT_MX17:
    Set rng3 = Selection
    If mX17 < 0 Then
        Application.CutCopyMode = False
        Range("A1").Select
        On Error GoTo 0
        End
    End If
    If mX17 = rng3.Value Then
        ActiveCell.Offset(0, 4).Select
    Else
        Cells.Find(What:=mX17, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False).Activate
        If ActiveCell.Offset(0, 2) <> mX17 Then
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 1)).Select
            Selection.Copy
            Selection.Offset(0, 2).Select
            Selection.Insert Shift:=xlToRight
            Application.CutCopyMode = False
            ActiveCell.Select
            ActiveCell.Offset(0, -2).Select
            ActiveCell.EntireColumn.Select
            Range(Selection, Selection.Offset(0, 3)).Select
            Selection.Cut
            Range("E1").Select
            Cells.Find(What:=mX16, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , SearchFormat:=False).Activate
            ActiveCell.Offset(0, 4).Select
            Selection.Insert Shift:=xlToRight
            ActiveCell.Offset(0, 4).Select
            End
        End If
        ActiveCell.EntireColumn.Select
        Range(Selection, Selection.Offset(0, 3)).Select
        Selection.Cut
        rng3.Select
        Selection.Insert Shift:=xlToRight
        If ActiveCell.Value = mX17 Then
            ActiveCell.Offset(0, 4).Select
        End If
    End If
    On Error GoTo 0

End
End Sub
 

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.
Sort by date Sort by votes
Hi.

How about using this method.

The built-in sort method usually sorts by rows but it can also sort by columns.
What we would need is a key which we can use to sort the columns properly.
We could add a row to the spreadsheet (and remove it afterwards) that would contain the key.

The sort of key we would need would be one that placed 17 before 16 and also before 1. This could be done by using a character string and padding the number with zeros. Note: The number of zeros used in the following macro will work for up to three digit numbers, only.) This will give, for instance: 017, 016 and 001 for the above examples.

If the Sensor Pointer number is blank in that column then we can use the one in the previous column.

To keep the pairs of columns in order we would need to add a suffix that will keep the column pairs together. For this we can use the column number. However, while the Sensor Pointer needs to be subject to a Descending sort order the column suffix will need an Ascending sort. To keep the sort sequences the same we must use not the column number but, say, 1000 minus the column number. For instance, for the first eight columns, this would give: 017-995, 017-994, 015-993, 015-992, 017-991, 017-990, 016-989, 016-988.

Once that extra row has been added then we can sort the data columns by row using that key.
Finally, we remove the row with the key.
Code: 
Option Explicit
Sub Sort_Columns()

    Dim ws As Worksheet
    Dim FirstCol As Long, LastCol As Long, LastRow As Long
    Dim ThisCell As Range
    Dim SensPtr As String
    
    Set ws = Worksheets("Sheet1")
    
    FirstCol = Range("E1").Column  ' The first column to be sorted
    
    With ws
        ' Insert Another Row
        Range("A1").EntireRow.Insert
        
        ' Find last data column number
        LastCol = .Cells.Find(What:="*", After:=[A1], searchorder:=xlByColumns, SearchDirection:=xlPrevious).Column - 1
        ' Find last data row number
        LastRow = .Cells.Find(What:="*", After:=[A1], searchorder:=xlByRows, SearchDirection:=xlPrevious).Row
        
        ' Add Sort Key in new row
        For Each ThisCell In Range(.Cells(2, FirstCol), .Cells(2, LastCol)) ' Loop over row 2
            If ThisCell = "" Then SensPtr = ThisCell.Offset(0, -1) Else SensPtr = ThisCell
            ThisCell.Offset(-1, 0) = Format(SensPtr, "000") & "-" & Format(1000 - ThisCell.Column, "000")
        Next

        ' Sort the data by column using the key
         With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range(Cells(1, FirstCol), Cells(1, LastCol)), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .SetRange Range(Cells(1, FirstCol), Cells(LastRow, LastCol))
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlLeftToRight
            .SortMethod = xlPinYin
            .Apply
        End With
        
        ' Delete the row with the keys
        .Rows(1).EntireRow.Delete
    End With

End Sub
 
Last edited:
Upvote 0
Correction:

"Once that extra row has been added then we can sort the data columns by row using that key."

should read:

"Once that extra row has been added then we can sort the data columns by column using that key."

Apologies
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question
Autofill after finding a text. Dynamic approach
Replies
3
Views
399
Joe4
Joe4
B
  • Question
Finding excluded values in excel
Replies
0
Views
221
bcmk29
B
P
  • Question
Help with Vba Code
Replies
3
Views
178
Coyotex3
C
G
  • Question
How can i extract the correct leave time on this code?
Replies
1
Views
374
rlv01
R
N
  • Question
My code is suddenly really slow
Replies
1
Views
158
RobP
R

Forum statistics

Threads
1,215,467
Messages
6,124,984
Members
449,201
Latest member
Lunzwe73

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top