Macro to arrange column order not working

[Prashant1211]

Hello VBA Experts,

In the following code, I open a file and copy the data from that file to my master file. Before I copy the data, I want to sort the columns in the open file according to my requirements. I have tried the following code but it does not work and have no idea what to change. Can anyone please help me to get the code corrected. Thanks


Dim search As Range
Dim cnt As Integer
Dim colOrdr As Variant
Dim indx As Integer
Dim FileToOpen As Variant
Dim OpenBook As Workbook
Dim LastRow As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files (*.xls*),*xls*")
If FileToOpen = False Then Exit Sub
Set OpenBook = Application.Workbooks.Open(FileToOpen)
LastRow = ActiveSheet.UsedRange.Rows.Count

OpenBook.Sheets(1).colOrdr = Array("Colli no list", "Item Number", "Material", "required Qty", "Base Unit of Measure", "Material Description", "Basic material", "Column name", "Document", "Drawing No.List") 'define column order with header names here
For indx = LBound(colOrdr) To UBound(colOrdr)
Set search = Rows("1:1").Find(colOrdr(indx), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not search Is Nothing Then
If search.Column <> cnt Then
search.EntireColumn.Cut
Columns(cnt).Insert Shift:=xlToRight
Application.CutCopyMode = False
End If
cnt = cnt + 1
End If
Next indx

 

[Alex Blakenburg]

See if making these changes fix it for you:

'Remove this line
'OpenBook.Sheets(1).colOrdr = Array("Colli no list", "Item Number", "Material", "required Qty", "Base Unit of Measure", "Material Description", "Basic material", "Column name", "Document", "Drawing No.List") 'define column order with header names here
'Replace with this line
colOrdr = Array("Colli no list", "Item Number", "Material", "required Qty", "Base Unit of Measure", "Material Description", "Basic material", "Column name", "Document", "Drawing No.List") 'define column order with header names here

cnt = 1                                         ' Added This line
For indx = LBound(colOrdr) To UBound(colOrdr)

 

[Prashant1211]

See if making these changes fix it for you:

'Remove this line
'OpenBook.Sheets(1).colOrdr = Array("Colli no list", "Item Number", "Material", "required Qty", "Base Unit of Measure", "Material Description", "Basic material", "Column name", "Document", "Drawing No.List") 'define column order with header names here
'Replace with this line
colOrdr = Array("Colli no list", "Item Number", "Material", "required Qty", "Base Unit of Measure", "Material Description", "Basic material", "Column name", "Document", "Drawing No.List") 'define column order with header names here

cnt = 1                                         ' Added This line
For indx = LBound(colOrdr) To UBound(colOrdr)

Hi, Thanks for your support but the above change didn't worked.

 

[Alex Blakenburg]

If you want to provide an XL2BB of some data that contains your headings and provide a before and after view, I can have a look tomorrow.
Also please elaborate on what "didn't work" means.

 

[Prashant1211]

If you want to provide an XL2BB of some data that contains your headings and provide a before and after view, I can have a look tomorrow.
Also please elaborate on what "didn't work" means.

Hi, Many thanks for your help. Below is my code in my Master excel in which I want to import data from other excel file. Other excel file has many columns (column order varies based on user profile) so first I like to arrange the columns and then copy the required to my master excel file. refer attached image for column order as example.



Private Sub CommandButton1_Click()
Dim answer As Integer

If Range("A12").Value >= 1 Then

answer = MsgBox("Project data already Exist, Reset Application ?", vbQuestion + vbYesNo)

If answer = vbYes Then

Call Reset


Else

Exit Sub

End If
End If


On Error Resume Next
Dim search As Range
Dim cnt As Integer
Dim colOrdr As Variant
Dim indx As Integer
Dim FileToOpen As Variant
Dim OpenBook As Workbook
Dim LastRow As Long

Application.DisplayAlerts = False
Application.ScreenUpdating = False
FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files (*.xls*),*xls*")
If FileToOpen = False Then Exit Sub
Set OpenBook = Application.Workbooks.Open(FileToOpen)
LastRow = ActiveSheet.UsedRange.Rows.Count
OpenBook.Sheets(1).Activate
'column order

colOrdr = Array("Colli no list", "Item Number", "Material", "required Qty", "Base Unit of Measure", "Material Description", "Basic material", "Column name", "Document", "Drawing No.List") 'define column order with header names here
cnt = 1
For indx = LBound(colOrdr) To UBound(colOrdr)
Set search = Rows("1:1").Find(colOrdr(indx), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not search Is Nothing Then
If search.Column <> cnt Then
search.EntireColumn.Cut
Columns(cnt).Insert Shift:=xlToRight
Application.CutCopyMode = False
End If
cnt = cnt + 1
End If
Next indx


'column order

OpenBook.Sheets(1).Range("A1:J1" & LastRow).Copy
ThisWorkbook.Worksheets("Main Sheet").Activate
Sheets.Add(After:=Sheets("Main Sheet")).Name = "Sheet1"
Sheets("Sheet1").Select
ActiveSheet.Paste

ThisWorkbook.Worksheets("Main Sheet").Activate

 

[Alex Blakenburg]

You still haven't told me what "doesn't work" means ?

Based on your image, you seem to have your column array in the wrong order.
It has Document & Drawing No.List as the "last" 2 items while your image in post #5 has them as the 1st 2 items.

If that is what is wrong with the result simple reaarange your array eg.

colOrdr = Array("Document", "Drawing No.List", "Colli no list", "Item Number", "Material", "required Qty", "Base Unit of Measure", "Material Description", "Basic material", "Column name") 'define column order with header names here

If not please show me what you are getting and also what you should be getting.

 

[Prashant1211]

You still haven't told me what "doesn't work" means ?

Based on your image, you seem to have your column array in the wrong order.
It has Document & Drawing No.List as the "last" 2 items while your image in post #5 has them as the 1st 2 items.

If that is what is wrong with the result simple reaarange your array eg.

colOrdr = Array("Document", "Drawing No.List", "Colli no list", "Item Number", "Material", "required Qty", "Base Unit of Measure", "Material Description", "Basic material", "Column name") 'define column order with header names here

If not please show me what you are getting and also what you should be getting.

My mistake I have not explained, sorry.

The image is only an example initially how the column order can be, but it can be in any order and from my code I want to defined them in fixed order. column order mentioned in code is my requirement. Unfortunately nothing happens when i run the code & the data gets copied without changing the column order.

Let me know if this is clear or you have more questions. Thanks

 

[Tupe77]

Did you mean something like this?

Sub Reorder_Columns()
Dim CopyFromWS As Worksheet: Set CopyFromWS = ThisWorkbook.Sheets("Main Sheet")
Dim WriteWs As Worksheet: Sheets.Add(After:=Sheets("Main Sheet")).Name = "Sheet1": Set WriteWs = ThisWorkbook.Worksheets("Sheet1")
Dim ColOrdArr As Variant, Found As Range
Dim ind As Integer, counter As Integer: counter = 1

ColOrdArr = Array("Colli no list", "Item Number", "Material", "required Qty", "Base Unit of Measure", "Material Description", "Basic material", "Column name", "Document", "Drawing No.List")

    Application.ScreenUpdating = False
    
        For ind = LBound(ColOrdArr) To UBound(ColOrdArr)
            Set Found = CopyFromWS.Rows("1:1").Find(ColOrdArr(ind), LookIn:=xlValues, LookAt:=xlWhole, _
                              SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
            
            If Not Found Is Nothing Then
                    Found.EntireColumn.Copy
                    WriteWs.Columns(counter).Insert Shift:=xlToRight
                    Application.CutCopyMode = False
                counter = counter + 1
            End If
            
        Next ind
        
    Application.ScreenUpdating = True
End Sub

 

[Tupe77]

I moved the fixes to your original code, hope it works as intended?
It does not modify the opened file, but the organization is done by copying the columns to a new sheet.

Private Sub CommandButton1_Click()
Dim answer As Integer
    If Range("A12").Value >= 1 Then
        answer = MsgBox("Project data already Exist, Reset Application ?", vbQuestion + vbYesNo)
        If answer = vbYes Then
            Call Reset
        Else
            Exit Sub
        End If
    End If
On Error Resume Next

Dim search As Range
Dim cnt As Integer
Dim colOrdr As Variant
Dim indx As Integer
Dim FileToOpen As Variant
Dim OpenBook As Workbook
Dim LastRow As Long

Application.DisplayAlerts = False
Application.ScreenUpdating = False
FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files (*.xls*),*xls*")
If FileToOpen = False Then Exit Sub
Set OpenBook = Application.Workbooks.Open(FileToOpen)
'LastRow = ActiveSheet.UsedRange.Rows.Count
'OpenBook.Sheets(1).Activate
Dim CopyFromWS As Worksheet: Set CopyFromWS = OpenBook.Worksheets(1)
ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets("Main Sheet")).Name = "Sheet1"
Dim WriteWs As Worksheet: Set WriteWs = ThisWorkbook.Worksheets("Sheet1")

'column order
colOrdr = Array("Colli no list", "Item Number", "Material", "required Qty", "Base Unit of Measure", "Material Description", "Basic material", "Column name", "Document", "Drawing No.List") 'define column order with header names here
cnt = 1

For indx = LBound(colOrdr) To UBound(colOrdr)
    Set search = CopyFromWS.Rows("1:1").Find(colOrdr(indx), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
        If Not search Is Nothing Then
            search.EntireColumn.Copy
            WriteWs.Columns(cnt).Insert Shift:=xlToRight
            Application.CutCopyMode = False
            cnt = cnt + 1
        End If
Next indx

Application.ScreenUpdating = True: Application.DisplayAlerts = True
ThisWorkbook.Worksheets("Main Sheet").Activate
End Sub

 

[johnnyL]

Here is the code that I have come up with to open the workbook, rearrange the column order & copy the rearranged columns to the main workbook. It only has one quick loop to convert the header names to column numbers:

Sub OpenRearrangeColumns()
'
    Dim HeaderRow                   As Long
    Dim colOrdr                     As Variant, ColumnNumberOrderArray  As Variant
    Dim FileToOpen                  As Variant
    Dim OpenBook                    As Workbook
'
    Application.ScreenUpdating = False
'
    Sheets.Add(After:=Sheets("Main Sheet")).Name = "Sheet1"
'
    HeaderRow = 1                                                                                                                       ' <--- Set this to row # that header row will be located on
'
    FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files (*.xls*),*xls*")
    If FileToOpen = False Then Exit Sub
'
    Set OpenBook = Application.Workbooks.Open(FileToOpen)
'
    colOrdr = Array("Colli no list", "Item Number", "Material", "required Qty", "Base Unit of Measure", "Material Description", _
            "Basic material", "Column name", "Document", "Drawing No.List")                                                             'define column order with header names here
'
    ReDim ColumnNumberOrderArray(0 To UBound(colOrdr))
'
    For i = 0 To UBound(colOrdr)
        ColumnNumberOrderArray(i) = Application.Match(colOrdr(i), Sheets(1).Rows(HeaderRow), 0)
    Next
'
    With Sheets(1)
        .Range("A1").Resize(.Cells.Find("*", , xlFormulas, , xlRows, xlPrevious).Row, UBound(ColumnNumberOrderArray) + 1) = _
            Application.Index(.Cells, Evaluate("ROW(1:" & .Cells.Find("*", , xlFormulas, , xlRows, xlPrevious).Row & ")"), ColumnNumberOrderArray)
'
        .Range("A1:J" & .Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row).Copy ThisWorkbook.Sheets("Sheet1").Range("A1")
    End With
'
    ThisWorkbook.Sheets("Sheet1").UsedRange.EntireColumn.AutoFit
'
    Application.Goto ThisWorkbook.Sheets("Main Sheet").Range("A1")
'
    Application.ScreenUpdating = True
'
' At this point, the workbook that was opened is still altered & open ;)
'
End Sub

Chew on that for a while.