CODEWITHSUNDEEP
vbaexcel
Gregory
Gregory

Reputation: 315

Reordering column headers by name

I am attempting to reorder column headers by name, though I'm running into a couple issues. The first is that some column headers are the same (they are like this from the export). The second is that the current code I am using does not seem to arrange all headers properly on the first go around, or some times at all. The third is that it is fairly slow to run.

Code below:

Dim arrColOrder As Variant, i As Integer
Dim Found As Range, counter As Integer


arrColOrder = Array("Reporting Status", "CloseRecord", "Tracking Number", "Close Record", "Tracking Number", "Close Record: Only")

counter = 1

Application.ScreenUpdating = False

For i = LBound(arrColOrder) To UBound(arrColOrder)

    Set Found = Rows("1:1").Find(arrColOrder(i), LookIn:=xlValues, LookAt:=xlWhole, _
                      SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=True)

    If Not Found Is Nothing Then
        If Found.Column <> counter Then
            Found.EntireColumn.Cut
            Columns(counter).Insert Shift:=xlToRight
            Application.CutCopyMode = False
        End If
        counter = counter + 1
    End If

Next i

Application.ScreenUpdating = True

End Sub

Upvotes: 0

Views: 80

Answers (1)

Subodh Tiwari sktneer
Subodh Tiwari sktneer

Reputation: 9976

What about this?

Dim Rng As Range
Dim arrColOrder As Variant, i As Integer, lc As Integer
Dim Found As Range

arrColOrder = Array("Reporting Status", "CloseRecord", "Tracking Number", "Close Record", "Tracking Number", "Close Record: Only")


Application.ScreenUpdating = False

lc = Cells(1, Columns.Count).End(xlUp).Column
Set Rng = Range(Cells(1, 1), Cells(1, lc))

For i = LBound(arrColOrder) To UBound(arrColOrder)

    Set Found = Rng.Find(arrColOrder(i), LookIn:=xlValues, LookAt:=xlWhole, _
                      SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=True)

    If Not Found Is Nothing Then
        If Found.Column = i + 1 Then GoTo Skip
            If Found.Column <> i + 1 Then
                Found.EntireColumn.Cut
                Columns(i + 1).Insert Shift:=xlToRight
                Application.CutCopyMode = False
                Set Rng = Range(Cells(1, Found.Column + 1), Cells(1, lc))
            End If
    End If
Skip:
Next i

Application.ScreenUpdating = True

Upvotes: 1

Related Questions