Sort Columns based on the headers using VBA

[GirishDhruva]

Hi Everyone,

Could someone suggest me how to sort the columns based on the headers present in the column A with column F.

Mr_Excel_Column_Adjustment.xlsm

Shared with Dropbox

www.dropbox.com

Check with the above attachment.

In sheet "Base" i have the columns without sorting, Like mentioned above i need to sort the columns based on the headers present in Column A with Column F and if not found then that data from column F to column I should go to last row.

If not found in Column A then the row from column F should be empty, like in the Output sheet.

 

[davesexcel]

I don't get the same results as you.

Sub test()
    Dim sh As Worksheet, LstRw As Long, rng As Range, c As Range, cRng As Range
    
    Set sh = Sheets("Base")
    With sh
        LstRw = .Cells(.Rows.Count, "F").End(xlUp).Row
        Set rng = .Range("F4:F" & LstRw)
        For Each c In rng.Cells
            If Application.WorksheetFunction.CountIf(.Columns(1), c) = 0 Then
                Set cRng = .Range(.Cells(c.Row, "F"), .Cells(c.Row, "I"))
                    cRng.Copy .Cells(.Rows.Count, "F").End(xlUp).Offset(1)
                    cRng.ClearContents
                
            End If
        Next c
    End With


End Sub

 

[GirishDhruva]

Hi @davesexcel,

This works partially but how to arrange in the same row as the data on Column A with Column F.

That is the main thing as the provided input is just a sample i have a huge data where if i try manually it drains more of my time.

Thanks for your precious effort and time.

Could you suggest with the another part.

 

[Fluff]

How about

Sub GirishDhruva()
   Dim Bary As Variant, Iary As Variant, Nary As Variant
   Dim r As Long, nr As Long, x As Long
   
   With Sheets("Base")
      Bary = .Range("A4", .Range("A" & Rows.Count).End(xlUp)).Resize(, 4).Value2
      Iary = .Range("F4", .Range("F" & Rows.Count).End(xlUp)).Resize(, 4).Value2
   End With
      nr = UBound(Bary)
   ReDim Nary(1 To UBound(Bary) + UBound(Iary), 1 To 4)
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Bary)
         .Item(Bary(r, 1)) = r
      Next r
      For r = 1 To UBound(Iary)
         If .Exists(Iary(r, 1)) Then
            x = .Item(Iary(r, 1))
         Else
            nr = nr + 1
            x = nr
         End If
         Nary(x, 1) = Iary(r, 1)
         Nary(x, 2) = Iary(r, 2)
         Nary(x, 3) = Iary(r, 3)
         Nary(x, 4) = Iary(r, 4)
      Next r
   End With
   Sheets("Base").Range("K4").Resize(nr, 4).Value = Nary
End Sub

Currently outputs the data in K:N to check it's right.

 

[GirishDhruva]

Hi @Fluff,

It worked perfectly.

Thanks for your effort and valuable time.

@davesexcel Thanks for your effort too.

 

[Fluff]

Glad we could help & thanks for the feedback.