Rearrange Columns on Each Sheet in Workbook

[mjcanty]

<code style="margin: 0px; padding: 0px; font-style: inherit; font-weight: inherit;">Hi Everyone,
I have a macro that deletes unnecessary columns and rearranges the remaining columns perfectly for the active sheet, but there are three other sheets that have the same headers, but different data. My goal is to have the macro delete and rearrange the columns on each sheet. I'm stuck and it's starting to make me go crazy. Please help!

Sub DDO_BMG()
'
' DDO_BMG Macro
'
Dim aCell As Range
Dim ws As Worksheet


    Application.ScreenUpdating = False


    For Each ws In Sheets
        With ws
            For Each aCell In .UsedRange
                If Not aCell.Value = "" And aCell.HasFormula = False Then
                    With aCell
                        .Value = Replace(.Value, Chr(160), "")
                        .Value = Application.WorksheetFunction.Clean(.Value)
                        .Value = Trim(.Value)
                    End With
                End If
            Next aCell
        End With
    Next ws


    For Each ws In Sheets
        On Error Resume Next
        ws.Cells(1, 13).EntireColumn.Delete
        ws.Cells(1, 12).EntireColumn.Delete
        ws.Cells(1, 9).EntireColumn.Delete
        ws.Cells(1, 1).EntireColumn.Delete
        ws.Cells(1, 10).Value = "STATUS"
        ws.Cells(1, 11).Value = "USER RESPONSE"
        ws.Cells(1, 12).Value = "COMMENTS"
        ws.Cells.EntireColumn.AutoFit
    Next ws


Dim v As Variant, x As Variant, findfield As Variant
Dim oCell As Range
Dim iNum As Long
v = Array("UserName", "FIRST_NAME", "LAST_NAME", "EMAIL_ID", "AU_NAME", "DatabaseName", "TVMName", "LogDate", "access_cnt", "STATUS", "USER RESPONSE", "COMMENTS")
For x = LBound(v) To UBound(v)
findfield = v(x)
iNum = iNum + 1
Set oCell = ActiveSheet.Rows(1).Find(What:=findfield, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)


If Not oCell.Column = iNum Then
Columns(oCell.Column).Cut
Columns(iNum).Insert Shift:=xlToRight
End If
Next x
Columns(9).NumberFormat = "0"
ws.Cells.EntireColumn.AutoFit




End Sub

</code>

 

[tonyyy]

Comment out the "On Error Resume Next" line and add the following two lines immediately below the "Set oCell = ws...."

Debug.Print findfield
Debug.Print oCell.Address

I suspect you'll receive an error. Please note the error number, description and the offending line of code. And also let me know the values of the Debug.Print statements.

It would help if you could post the original headers in the order they appear, then the headers in the order you wish them to be.

 

[mjcanty]

"On Error Resume Next" has been commented out and the two Debug lines were added immediately below Set oCell =ws

Set oCell = ws.Rows(1).Find(What:=findfield, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    Debug.Print findfield
    Debug.Print oCell.Address

I did not receive any error message.


Original Headers

<blank column="" header=""></blank>

LogDate

DatabaseName <tbody> </tbody>

UserName <tbody> </tbody>

TVMName <tbody> </tbody>

FIRST_NAME <tbody> </tbody>

LAST_NAME <tbody> </tbody>

access_cnt <tbody> </tbody>

AU_NUM <tbody> </tbody>

EMAIL_ID <tbody> </tbody>

AU_NAME <tbody> </tbody>

RGN_NAME <tbody> </tbody>

GRP_NAME <tbody> </tbody>

<tbody>
</tbody>

Updated Headers (after macro deletes unnecessary columns and adds new columns)

UserName <tbody> </tbody>

FIRST_NAME <tbody> </tbody>

LAST_NAME <tbody> </tbody>

EMAIL_ID <tbody> </tbody>

AU_NAME <tbody> </tbody>

DatabaseName <tbody> </tbody>

TVMName <tbody> </tbody>

LogDate <tbody> </tbody>

access_cnt <tbody> </tbody>

STATUS

USER RESPONSE

COMMENTS

<tbody>
</tbody>

 

[tonyyy]

So, the before and after headers each have 12 columns, yet the macro includes a statement to delete Column 13. That clue revealed that some of the column deletions and additions were offset so the appropriate changes were made.

Sub DDO_BMG()
'
' DDO_BMG Macro
'
Dim aCell As Range
Dim ws As Worksheet

Application.ScreenUpdating = False

For Each ws In Sheets
    With ws
        For Each aCell In .UsedRange
            If Not aCell.Value = "" And aCell.HasFormula = False Then
                With aCell
                    .Value = Replace(.Value, Chr(160), "")
                    .Value = Application.WorksheetFunction.Clean(.Value)
                    .Value = Trim(.Value)
                End With
            End If
        Next aCell
    End With
Next ws

For Each ws In Sheets
    On Error Resume Next
    ws.Cells(1, 12).EntireColumn.Delete
    ws.Cells(1, 11).EntireColumn.Delete
    ws.Cells(1, 8).EntireColumn.Delete
    ws.Cells(1, 11).Value = "STATUS"
    ws.Cells(1, 12).Value = "USER RESPONSE"
    ws.Cells(1, 13).Value = "COMMENTS"
    ws.Cells.EntireColumn.AutoFit
Next ws

For Each ws In Sheets
    Dim v As Variant, x As Variant, findfield As Variant
    Dim oCell As Range
    Dim iNum As Long
    v = Array("UserName", "FIRST_NAME", "LAST_NAME", "EMAIL_ID", "AU_NAME", "DatabaseName", "TVMName", "LogDate", "access_cnt", "STATUS", "USER RESPONSE", "COMMENTS")
    For x = LBound(v) To UBound(v)
        findfield = v(x)
        iNum = iNum + 1
        Set oCell = ws.Rows(1).Find(What:=findfield, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        
        If Not oCell.Column = iNum Then
            ws.Columns(oCell.Column).Cut
            ws.Columns(iNum).Insert Shift:=xlToRight
        End If
    Next x
    ws.Columns(9).NumberFormat = "0"
    ws.Cells.EntireColumn.AutoFit
    iNum = 0
Next ws

End Sub