• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

How to re-arrange columns in pre-defined serial order

ThrottleWorks

ThrottleWorks

Excel Ninja
Hi,

I am using below mentioned code to re-arrange data in a worksheet.
This way, I am sure that the columns will be in a particular order before applying in code.

Can anyone please suggest me a better solution, please note, I am not facing any issue due this, it is not urgent for me.
Code: 
Sub Re_Arrange_Columns()
    Dim HeaderRng As Range
    Dim DeleteBook As Workbook
    Dim DeleteSht As Worksheet
    Dim rng As Range

    RawBook.Activate
    Set HeaderRng = MapSht.Range(MapSht.Cells(2, 1), MapSht.Cells(55, 1)) ‘This is where column headers are stored
 
    RawSht.Cells.Copy ‘this is the workbook I am trying to re-arrange
    Workbooks.Add
    Range("A1").PasteSpecial xlPasteAll

    Set DeleteBook = ActiveWorkbook
    Set DeleteSht = ActiveSheet

    RawSht.Cells.Clear
    Dim ColCount As Long
    ColCount = 0

    For Each rng In HeaderRng
        ColCount = ColCount + 1

        Cells.Find(What:="" & rng, After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate

        ActiveCell.EntireColumn.Copy
        RawSht.Cells(1, ColCount).PasteSpecial xlPasteAll
    Next rng
 
    DeleteBook.Close
End Sub
 
Hi @Chihiro sir, thanks a lot for the help.

Could you please help me with array if you get time. I am not able to provide range to my array. For example, if my headers are stored in range A2:A6, how do I pass this range to array.

I am trying to replace 'nams = Array("ItemID", "FirstName", "LastName", "Address", "Week", "Month", "Year")' with range.

I tried using Google since yesterday but not able to do so.
Can you please help if possible.
 
Something like
Code: 
nams = Application.Transpose(Range("A2:A6")).Value)

Note that you need to change "F = 0 to UBound(nams)" in that case (and the subsequent logic). Since array will not start on 0 when transposed and you need to start it on 1.

If you need further help. Upload sample workbook.
 
Last edited:
Hi @Chihiro sir, thanks a lot for the help. I tried as suggested by you, however not able to get output.

Could you please help if you get time.
 

Attachments

  • Chandoo.xls
    36.5 KB · Views: 5
Using some work from p45cal, I posted a question like yours recently. Please note, there is one correction that I've incorporated in the code below (recent post).

Apologies if I've left any subs out; I use a lot of custom subs and rather than include all the extras, I try to post using generic solutions (ie, UsedRange). If I've omitted any, please point them out and I'll either provide the sub/function or a generic solution.

Please note, the order is hard-coded in the calling sub (run_sor_Columns_arr).

hth,

Dr. D

Code: 
Option Explicit
Option Base 1

Sub run_sort_Columns_arr()

Dim sht As Worksheet
  Set sht = ActiveSheet

Dim arr As Variant
  arr = Array("a", "b", "c", "d", "e")

  sort_Columns_arr sht, arr

End Sub


Public Sub sort_Columns_arr(Optional ths As Worksheet, _
                            Optional rraOrder As Variant)
' ~~ Sorts columns using an array to direct order; _
      however, will not order columns not listed in array _
      ***** twice as FAST as range version *****
' http://forum.chandoo.org/threads/re-arranging-columns-basis-hdr-names-vba-codes-using-array.24537/

Dim wbk As Workbook
  Set wbk = ActiveWorkbook
If ths Is Nothing Then _
  Set ths = wbk.ActiveworkSheet

Dim rngUsed As Range, _
    rngHdr As Range, _
    rngDest As Range, _
    rng As Range, _
    cell As Range
  Set rngUsed = ths.UsedRange
  Set rngHdr = rngUsed.Rows(1)

Dim cntr As Long, _
    colArr As Long, _
    rowArr As Long, _
    cntrRow As Long, _
    maxRow As Long, _
    colArr_max As Long
  maxRow = rngUsed.Rows.Count
  colArr = 0
  colArr_max = 0

Dim str_shtName As String

Dim arrResults As Variant, _
    hdr As Variant, _
    arrHdr As Variant, _
    arr As Variant


  ReDim arrHdr(1 To UBound(rraOrder))

  For Each hdr In rraOrder
    Set rng = rngHdr.find(What:=hdr, _
                          LookAt:=xlWhole, _
                          LookIn:=xlValues, _
                          MatchCase:=False, _
                          searchformat:=False)

    ' ~~ If rng is cannot be found in rngUsed, skip to next entry in rraOrder
    If Not rng Is Nothing Then
      colArr_max = colArr_max + 1
      Set arrHdr(colArr_max) = rng ' adds the hdr cell to the array for later use
'      Debug.Print "arrHdr(" & colArr_max & ") | " & arrHdr(colArr_max)
    End If
  Next hdr

  ' ~~ To ReDim array to proper size, must only use header variables found in rngHdr
  ReDim Preserve arrHdr(1 To colArr_max)
  ReDim arrResults(1 To maxRow, 1 To colArr_max) ' ~~ ReDim the final size of the array

  For Each hdr In arrHdr 'takes each of the hdr cells in turn
    colArr = colArr + 1
    With hdr.Resize(maxRow)  'expands the range
      arr = .value 'puts the values into memory (arr)
      .ClearContents 'clears that column's contents; the values are stored in memory.
    End With

    For rowArr = 1 To maxRow  ' ~~ importing each cell of the column into array
      arrResults(rowArr, colArr) = arr(rowArr, 1) ' and put it into the final result array
    Next rowArr

  Next hdr

  With ths
    .Select
    rngUsed.Cells(1, 1).Resize(maxRow, colArr) = arrResults ' ~~ Copy final array onto the destination sheet
'    rngUsed.Range(Cells(, colArr_max + 1), Cells(, rngUsed.Columns.count)).EntireColumn.Delete  ' ~~ Delete "extra" data outside specified array
  End With

End Sub
 
Last edited:
@ThrottleWorks

You had column header in range A1:A5, not A2:A6.

Only other change needed is to change "If F < i then" to...
"If F - 1 < i Then".

Full code for your sample:
Code: 
Sub MG26May36()
    Dim rng As Range
    Dim i As Integer
    Dim J As Integer
    Dim Temp
    Dim nams As Variant
    Dim F
    Dim Dex As Integer
   
    Dim ArSht As Worksheet
    Dim ResultSht As Worksheet

    Set ArSht = ThisWorkbook.Worksheets("Sheet1")
    Set ResultSht = ThisWorkbook.Worksheets("Sheet2")
   
    nams = Application.Transpose(ArSht.Range("A1:A5"))
   
    Set rng = ResultSht.Range("A1").CurrentRegion
    For i = 1 To rng.Columns.Count
        For J = i To rng.Columns.Count
            For F = 1 To UBound(nams)
                If nams(F) = rng(J) Then Dex = F: Exit For
            Next F
            If F - 1 < i Then
                Temp = rng.Columns(i).Value
                rng(i).Resize(rng.Rows.Count) = rng.Columns(J).Value
                rng(J).Resize(rng.Rows.Count) = Temp
            End If
        Next J
    Next i
End Sub

See attached sample as well.
 

Attachments

  • Chandoo (5).xls
    30 KB · Views: 8
Hi @Chihiro sir, thanks a lot, I was un aware about using 'If F - 1 < i Then', my mistake.

It is working nice now, have a nice day ahead. :)

PS - Sure sir, will keep suggestion regarding date format in mind.
 
Does this help, I use it to arrange columns in a desired order

Put your columns in any order by placing column headers in the order you need
Code: 
Sub iRearangeCols()
  'add as many as you want
  RearangeCols "mySheetName", Array("Header10", "Header3", "Header7")

End Sub

'Rearange Columns
Function RearangeCols(shtName As String, HeaderNames As Variant)
Dim ws As Worksheet
Dim colFrom As Long
Dim l As Long

Set ws = ThisWorkbook.Sheets(shtName)

On Error GoTo Skipit
For l = 0 To UBound(HeaderNames)
    colFrom = ws.Rows(1).Find(HeaderNames(l), , xlValues, xlWhole).Column
    If l + 1 <> colFrom Then ws.Columns(colFrom).Cut: ws.Columns(l + 1).insert
Skipit:
Next

On Error GoTo 0
End Function
 
Then you would have

Code: 
Sub iRearangeCols()

  nams = Application.Transpose(Range("A2:A6").Value)
  RearangeCols "mySheetName", nams

End Sub
 
Last edited:
Because

myHeaderList = Array("Header10", "Header3", "Header7") is a Zero based array

And

nams = Application.Transpose(Range("A2:A6").Value) is a one dimintional array

You will need to make nams a zero-dimensional array

Use

Code: 
Function RngToList(rng As Range) As Variant

  RngToList = Split(Join(WorksheetFunction.Transpose(rng.Value2), "|"), "|")

End Function

Then we have

Code: 
Sub iRearangeCols()

  nams = RngToList(Range("A2:A6"))
  RearangeCols "mySheetName", nams

End Sub
 
You must log in or register to reply here.
Back
Top