Rearrange Columns on Each Sheet in Workbook

M

mjcanty

New Member
Joined
Feb 9, 2016
Messages
17
Office Version
  1. 2016
Platform
  1. Windows
<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!

Code: 
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>
 

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.
Sort by date Sort by votes
You might try making the highlighted modifications...

Code: 
[COLOR=#a9a9a9]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
[/COLOR][COLOR=#0000ff]'Next ws

'For Each ws In Sheets[/COLOR][COLOR=#a9a9a9]
    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
[/COLOR][COLOR=#0000ff]'Next ws[/COLOR][COLOR=#a9a9a9]

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

[/COLOR][COLOR=#0000ff]Next ws
Application.ScreenUpdating = True [/COLOR][COLOR=#a9a9a9]
End Sub[/COLOR]

Cheers,

tonyyy
 
Upvote 0
Thanks for your reply, Tonyyy. I made the updates you suggested and the macro runs; however, the data on the first sheet starts in column Y and there is an empty column after every subsequent column. Additionally, the columns in the second, third, and fourth sheets are not being rearranged.
 
Upvote 0
Is the code you posted the code that works perfectly for the active sheet?
 
Upvote 0
Yes, the code in my OP worked perfectly for the active sheet, but it does not work for any subsequent sheet. When I revised the code with your suggestion, it appears that empty columns are inserted and my data begins in column Y, as well as empty columns in between all subsequent columns of data on the active sheet.
 
Upvote 0
Thanks for the confirmation. In that case, we'll try cycling through each worksheet for the last part of the code:

Code: 
[COLOR=#a9a9a9]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

[/COLOR][COLOR=#0000ff]For Each ws In Sheets[/COLOR][COLOR=#a9a9a9]
    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
   [/COLOR][COLOR=#0000ff] iNum = 0[/COLOR][COLOR=#a9a9a9]
[/COLOR][COLOR=#0000ff]Next ws[/COLOR][COLOR=#a9a9a9]

End Sub[/COLOR]
 
Upvote 0
This revision works perfectly for the active sheet and deletes the unnecessary columns and autofits everything in each subsequent sheet, but does not rearrange them.
 
Upvote 0
Change this line:

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

To this:

Code: 
Set oCell = [COLOR=#0000ff]ws[/COLOR].Rows(1).Find(What:=findfield, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
 
Upvote 0
This didn't do it. The columns are not in the correct order based on the array on any of the sheets.
 
Upvote 0
This is what my code looks like now:

Code: 
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


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
    Columns(oCell.Column).Cut
    Columns(iNum).Insert Shift:=xlToRight
    End If
Next x
Columns(9).NumberFormat = "0"
ws.Cells.EntireColumn.AutoFit
iNum = 0
Next ws


End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Solved
Stop excel macro from running if there is a blank cell in a column
Replies
5
Views
153
RobP
R
A
  • Question
VBA if a row is all blank in a range of columns, highlight the blanks and the headers
2 3 4
Replies
31
Views
496
AnnAnn
A
G
  • Solved
Macro not reaching bottom of the worksheet (due to blank rows)
Replies
5
Views
185
Peter_SSs
Peter_SSs
I
  • Question
Error in using VBA Macro with Apply Colors and Line Numbers
Replies
3
Views
108
intellitechdataservices
I
E
  • Solved
VBA -highlighting rows when a condition is met
Replies
2
Views
173
Evie76
E

Forum statistics

Threads
1,214,998
Messages
6,122,638
Members
449,093
Latest member
Ahmad123098

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top