How to rearrange columns based on a numbering scheme

[dougebowl]

Hi All!

I am looking for a way to rearrange columns based on the numbering scheme in row 1. I need the columns rearranged and all the data to move within the column.

For Example: Columns are numbered 1, 4, 9, 2, 3, 8, 7, 6 and when completed, I need the columns in numerical order 1, 2, 3, 4, 5, 6, 7, 8, 9 along with the date in the columns to move with it. It is like performing a Cut/Insert Cut Columns. My spreadsheet is large, so manually doing this takes time and am wondering if there is an automated way using visual basic or built in functionality in Excel.

Thanks in advance for any assistance.

 

[JLGWhiz]

Columns are numbered 1, 4, 9, 2, 3, 8, 7, 6

Are they entered as text or numbers.? Are there any leading or trailing spaces in the cells containting the numbers? Are there any merged cells in that row?

 

[DanteAmor]

Columns are numbered 1, 4, 9, 2, 3, 8, 7, 6

You missed 5.
The following macro works for 9 columns.

Sub rearrange_columns()
  Dim lr As Long, a As Variant, n As Long, i As Long, j As Long
  lr = ActiveSheet.Range("A:I").Find("*", , xlValues, , xlByRows, xlPrevious).Row
  a = Range("A1:I" & lr)
  ReDim b(1 To lr, 1 To UBound(a, 2))
  For j = 1 To 9
    n = a(1, j)
    For i = 1 To lr
      b(i, n) = a(i, j)
    Next
  Next
  Range("A1").Resize(lr, UBound(a, 2)).Value = b
End Sub

 

[Trebor76]

Here's my attempt:

Option Explicit
Sub Macro2()

    'https://www.mrexcel.com/board/threads/how-to-rearrange-columns-based-on-a-numbering-scheme.1133148/

    Dim objMyCols As Object
    Dim lngMyCol As Long
    Dim varMyCol As Variant
    Dim rngFindCol As Range
   
    Application.ScreenUpdating = False

    Set objMyCols = CreateObject("System.Collections.ArrayList")
   
    For lngMyCol = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
        objMyCols.Add CLng(Cells(1, lngMyCol))
    Next lngMyCol
   
    objMyCols.Sort 'Sort file names in ascending order
   
    For Each varMyCol In objMyCols
        Set rngFindCol = Rows("1:1").Find(CLng(varMyCol), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
        If Not rngFindCol Is Nothing Then
            If rngFindCol.Column <> CLng(varMyCol) Then
                rngFindCol.EntireColumn.Cut
                Columns(CLng(varMyCol)).Insert Shift:=xlToRight
            End If
        End If
    Next varMyCol
   
    Set objMyCols = Nothing
   
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[JLGWhiz]

Try this on a copy or mock up of your file before applying it to the original.

Sub t()
Dim fn As Range, i As Long
    With ActiveSheet
        For i = 1 To .Cells(1, Columns.Count).End(xlToLeft).Column
            Set fn = .Range(.Cells(1, i), .Cells(1, Columns.Count)).Find(i, , xlValues, xlWhole)
                If Not fn Is Nothing Then
                    fn.EntireColumn.Cut
                    On Error Resume Next
                    .Columns(i).Insert
                    On Error GoTo 0
                    Err.Clear
                End If
                Set fn = Nothing
        Next
    End With
End Sub

 

[DanteAmor]

If you have more than nine columns, here is my macro with a few small adjustments.

Sub rearrange_columns()
  Dim lr As Long, a As Variant, i As Long, j As Long
  lr = ActiveSheet.Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
  a = Range("A1", Cells(lr, Cells(1, Columns.Count).End(1).Column))
  ReDim b(1 To lr, 1 To UBound(a, 2))
  For j = 1 To UBound(a, 2)
    For i = 1 To lr
      b(i, a(1, j)) = a(i, j)
    Next
  Next
  Range("A1").Resize(lr, UBound(a, 2)).Value = b
End Sub