Combining repeating columns

Question

I am trying to write an excel macro to combine columns in a spreadsheet.
Specifically, there are seven columns, each with unique headers, that repeat indefinitely.

I want to combine all of the columns with the same headers into one, leaving only seven columns with all of the data. I do not want to concatenate the columns, but rather have each new column's data added to the previous one at the bottom.

As you can see in the code below, I have frankensteined it with macros I recorded and macros I have found online, as well as some of my own code here and there. It's very ineloquent and lengthy, and I'm sure there's an easier solution.

Sub Pop()
'
' Pop Macro
'
Dim i As Integer
Dim ws As Worksheet
Dim from_lastcol As Long
Dim from_lastrow As Long
Dim to_lastrow As Long
Dim from_colndx As Long
Dim ws_from As Worksheet, ws_to As Worksheet
Dim iSheetCount

    Application.ScreenUpdating = False
    'Format
    Application.ScreenUpdating = False
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=R[1]C"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "=IF(OR(R[1]C=R[1]C[-1]),"""",R[1]C)"
    Range("B1").Select
    Selection.Copy
    Range("C1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "=IF(OR(R[1]C=R[1]C[-1],R[1]C=R[1]C[-2]),"""",R[1]C)"
    Range("C1").Select
    Selection.Copy
    Range("D1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = _
        "=IF(OR(R[1]C=R[1]C[-1],R[1]C=R[1]C[-2],R[1]C=R[1]C[-3]),"""",R[1]C)"
    Range("D1").Select
    Selection.Copy
    Range("E1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = _
        "=IF(OR(R[1]C=R[1]C[-1],R[1]C=R[1]C[-2],R[1]C=R[1]C[-3],R[1]C=R[1]C[-4]),"""",R[1]C)"
    Range("E1").Select
    Selection.Copy
    Range("F1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = _
        "=IF(OR(R[1]C=R[1]C[-1],R[1]C=R[1]C[-2],R[1]C=R[1]C[-3],R[1]C=B2F2=R[1]C[-5]),"""",R[1]C)"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(OR(R[1]C=R[1]C[-1],R[1]C=R[1]C[-2],R[1]C=R[1]C[-3],R[1]C=R[1]C[-4],R[1]C=R[1]C[-5]),"""",R[1]C)"
    Range("F1").Select
    Selection.Copy
    Range("G1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = _
        "=IF(OR(R[1]C=R[1]C[-1],R[1]C=R[1]C[-2],R[1]C=R[1]C[-3],R[1]C=R[1]C[-4],R[1]C=B2G2=R[1]C[-6]),"""",R[1]C)"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(OR(R[1]C=R[1]C[-1],R[1]C=R[1]C[-2],R[1]C=R[1]C[-3],R[1]C=R[1]C[-4],R[1]C=R[1]C[-5],R[1]C=R[1]C[-6]),"""",R[1]C)"
    Range("G1").Select
    Selection.Copy
    Range("H1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = _
        "=IF(OR(R[1]C=R[1]C[-1],R[1]C=R[1]C[-2],R[1]C=R[1]C[-3],R[1]C=R[1]C[-4],R[1]C=R[1]C[-5],R[1]C=R[1]C[-6],R[1]C=R[1]C[-7]),"""",R[1]C)"
    Range("H1").Select
    Selection.Copy
    Range("I1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = _
        "=IF(OR(R[1]C=R[1]C[-1],R[1]C=R[1]C[-2],R[1]C=R[1]C[-3],R[1]C=R[1]C[-4],R[1]C=R[1]C[-5],R[1]C=R[1]C[-6],R[1]C=R[1]C[-7],R[1]C=R[1]C[-8]),"""",R[1]C)"
    Range("I1").Select
    Selection.Copy
    Range("J1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = _
        "=IF(OR(R[1]C=R[1]C[-1],R[1]C=R[1]C[-2],R[1]C=R[1]C[-3],R[1]C=R[1]C[-4],R[1]C=R[1]C[-5],R[1]C=R[1]C[-6],R[1]C=R[1]C[-7],R[1]C=R[1]C[-8],R[1]C=R[1]C[-9]),"""",R[1]C)"
    Rows("1:1").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False

    Rows("1:1").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets.Add
    Sheets("Sheet2").Select
    Sheets.Add
    Sheets("Sheet3").Select
    Sheets.Add
    Sheets("Sheet4").Select
    Sheets.Add
    Sheets("Sheet5").Select
    Sheets.Add
    Sheets("Sheet6").Select
    Sheets.Add
    Sheets("Sheet7").Select
    Sheets.Add
    Sheets("Sheet8").Select
    Sheets.Add
    Sheets("Sheet9").Select
    Sheets.Add
    Sheets("Sheet10").Select
    Sheets.Add
    Sheets("Sheet11").Select
    Sheets("Sheet11").Name = "Legend"
    ActiveSheet.Paste
    ActiveWindow.SmallScroll ToRight:=-4
    ActiveWindow.ScrollWorkbookTabs Sheets:=-1
    ActiveWindow.ScrollWorkbookTabs Sheets:=-1
    Sheets("Sheet1").Select
    Rows("1:1").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Sheets("Sheet2").Select
    'Format Sheet 2
    Sheets("Sheet2").Select
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=IF(Sheet1!R1C=Legend!R1C1,Sheet1!RC,""P"")"
    Range("A1").Select
    Selection.AutoFill Destination:=Range("A1:A500"), Type:=xlFillDefault
    Range("A1:A500").Select
    Selection.AutoFill Destination:=Range("A1:ZZ500"), Type:=xlFillDefault
    Range("A1:ZZ500").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Replace what:="P", Replacement:="", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("A1:ZZ1") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A1:ZZ500")
        .header = xlNo
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
    'Format Sheet 3
    Sheets("Sheet3").Select
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=IF(Sheet1!R1C=Legend!R1C2,Sheet1!RC,""P"")"
    Range("A1").Select
    Selection.AutoFill Destination:=Range("A1:A500"), Type:=xlFillDefault
    Range("A1:A500").Select
    Selection.AutoFill Destination:=Range("A1:ZZ500"), Type:=xlFillDefault
    Range("A1:ZZ500").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Replace what:="P", Replacement:="", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("A1:ZZ1") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A1:ZZ500")
        .header = xlNo
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
     'Format Sheet 4
     Sheets("Sheet4").Select
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=IF(Sheet1!R1C=Legend!R1C3,Sheet1!RC,""P"")"
    Range("A1").Select
    Selection.AutoFill Destination:=Range("A1:A500"), Type:=xlFillDefault
    Range("A1:A500").Select
    Selection.AutoFill Destination:=Range("A1:ZZ500"), Type:=xlFillDefault
    Range("A1:ZZ500").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Replace what:="P", Replacement:="", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("A1:ZZ1") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A1:ZZ500")
        .header = xlNo
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
    'Format Sheet 5
    Sheets("Sheet5").Select
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=IF(Sheet1!R1C=Legend!R1C4,Sheet1!RC,""P"")"
    Range("A1").Select
    Selection.AutoFill Destination:=Range("A1:A500"), Type:=xlFillDefault
    Range("A1:A500").Select
    Selection.AutoFill Destination:=Range("A1:ZZ500"), Type:=xlFillDefault
    Range("A1:ZZ500").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Replace what:="P", Replacement:="", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("A1:ZZ1") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A1:ZZ500")
        .header = xlNo
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
    'Format Sheet 6
    Sheets("Sheet6").Select
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=IF(Sheet1!R1C=Legend!R1C5,Sheet1!RC,""P"")"
    Range("A1").Select
    Selection.AutoFill Destination:=Range("A1:A500"), Type:=xlFillDefault
    Range("A1:A500").Select
    Selection.AutoFill Destination:=Range("A1:ZZ500"), Type:=xlFillDefault
    Range("A1:ZZ500").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Replace what:="P", Replacement:="", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("A1:ZZ1") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A1:ZZ500")
        .header = xlNo
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
    'Format Sheet 7
    Sheets("Sheet7").Select
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=IF(Sheet1!R1C=Legend!R1C6,Sheet1!RC,""P"")"
    Range("A1").Select
    Selection.AutoFill Destination:=Range("A1:A500"), Type:=xlFillDefault
    Range("A1:A500").Select
    Selection.AutoFill Destination:=Range("A1:ZZ500"), Type:=xlFillDefault
    Range("A1:ZZ500").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Replace what:="P", Replacement:="", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("A1:ZZ1") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A1:ZZ500")
        .header = xlNo
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
    'Format Sheet 8
    Sheets("Sheet8").Select
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=IF(Sheet1!R1C=Legend!R1C7,Sheet1!RC,""P"")"
    Range("A1").Select
    Selection.AutoFill Destination:=Range("A1:A500"), Type:=xlFillDefault
    Range("A1:A500").Select
    Selection.AutoFill Destination:=Range("A1:ZZ500"), Type:=xlFillDefault
    Range("A1:ZZ500").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Replace what:="P", Replacement:="", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("A1:ZZ1") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A1:ZZ500")
        .header = xlNo
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
    'Format Sheet 9
    Sheets("Sheet9").Select
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=IF(Sheet1!R1C=Legend!R1C8,Sheet1!RC,""P"")"
    Range("A1").Select
    Selection.AutoFill Destination:=Range("A1:A500"), Type:=xlFillDefault
    Range("A1:A500").Select
    Selection.AutoFill Destination:=Range("A1:ZZ500"), Type:=xlFillDefault
    Range("A1:ZZ500").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Replace what:="P", Replacement:="", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("A1:ZZ1") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A1:ZZ500")
        .header = xlNo
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
    'Format Sheet 10
    Sheets("Sheet10").Select
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=IF(Sheet1!R1C=Legend!R1C9,Sheet1!RC,""P"")"
    Range("A1").Select
    Selection.AutoFill Destination:=Range("A1:A500"), Type:=xlFillDefault
    Range("A1:A500").Select
    Selection.AutoFill Destination:=Range("A1:ZZ500"), Type:=xlFillDefault
    Range("A1:ZZ500").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Replace what:="P", Replacement:="", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("A1:ZZ1") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A1:ZZ500")
        .header = xlNo
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With

    'Cycle
    For i = 2 To 10
    mysheet = "Sheet" & i
    Sheets(mysheet).Select
    On Error GoTo Error_Handler
    'CollapseColumns
    Set ws_from = ActiveWorkbook.ActiveSheet
    Rows("1:1").Select
    Selection.Delete Shift:=xlUp
from_lastcol = ws_from.Cells(1, Columns.Count).End(xlToLeft).Column

'Turn error checking off so if no "AllData" trying to delete doesn't generate Error
On Error Resume Next
'so not prompted to confirm delete
Application.DisplayAlerts = False
'Delete if already exists so don't get error
ActiveWorkbook.Worksheets("AllData").Delete
Application.DisplayAlerts = True
'turn error checking back on
On Error GoTo 0

'since you refer to "AllData" throughout
Set ws_to = Worksheets.Add
ws_to.Name = "AllData"

For from_colndx = 1 To from_lastcol
    from_lastrow = ws_from.Cells(Rows.Count, from_colndx).End(xlUp).Row
    'If you're going to exceed 65536 rows
    If from_lastrow + ws_to.Cells(Rows.Count, 1).End(xlUp).Row <= 65536 Then
        to_lastrow = ws_to.Cells(Rows.Count, 1).End(xlUp).Row
    Else
        GoTo Error_Handler
    End If
    ws_from.Range(ws_from.Cells(1, from_colndx), ws_from.Cells(from_lastrow, _
      from_colndx)).Copy ws_to.Cells(to_lastrow + 1, 1)
Next
        For iSheetCount = 1 To Sheets.Count
        Sheets(iSheetCount).Name = iSheetCount
    Next iSheetCount

' this deletes any blank rows
ws_to.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Next i
Error_Handler:
    Sheets("Sheet2").Delete
    Sheets("Sheet3").Delete
    Sheets("Sheet4").Delete
    Sheets("Sheet5").Delete
    Sheets("Sheet6").Delete
    Sheets("Sheet7").Delete
    Sheets("Sheet8").Delete
    Sheets("Sheet9").Delete
    Sheets("Sheet10").Delete
    Sheets("AllData").Delete

Application.ScreenUpdating = True

End Sub

I've tried isolating the columns (sorting by header), then separating them based on header into different work sheets. Then I delete everything on that sheet that doesn't have a specific header. So after this there are seven sheets with the data I need. I also need to arrange all of these sheets into one column each and sort by ascending. This part has been tricky for me, and the macro takes a very very long time to run. — Ryan, Jan 22 '15 at 18:49
Please edit your question to include the code that you are using. There are a couple ways to accomplish what you want, so I'd like to see how you are currently handling it. — TheEngineer, Jan 22 '15 at 18:52

score 0 · Answer 1 · edited May 23 '17 at 12:17

First off, you should always avoid using Select, Selection, & ActiveCell as explained here. The macro recorder is a good place to start, so good job getting the macro to work!

I believe the following code will accomplish what you want to happen without having to add and delete sheets:

Option Explicit

Sub Test()

Dim ws              As Worksheet
Dim FirstLastRow    As Long
Dim curLastRow      As Long
Dim LastColumn      As Long
Dim i As Long, j As Long

Application.ScreenUpdating = False

Set ws = ThisWorkbook.Worksheets("Sheet1")
LastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column

For i = 1 To LastColumn
    FirstLastRow = ws.Cells(Rows.Count, i).End(xlUp).Row
    For j = LastColumn To i + 1 Step -1
        If ws.Cells(1, j).Value = ws.Cells(1, i).Value And i <> j Then
            curLastRow = ws.Cells(Rows.Count, j).End(xlUp).Row
            ws.Range(ws.Cells(2, j), ws.Cells(curLastRow, j)).Copy ws.Cells(FirstLastRow + 1, i)
            ws.Columns(j).Delete Shift:=xlToLeft
            FirstLastRow = ws.Cells(Rows.Count, i).End(xlUp).Row
        End If
    Next j
    LastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column
Next i

For i = 1 To LastColumn
curLastRow = ws.Cells(Rows.Count, i).End(xlUp).Row
With ws.Sort
    .SortFields.Clear
    .SortFields.Add Key:=ws.Range(ws.Cells(2, i), ws.Cells(curLastRow, i)), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    .SetRange ws.Range(ws.Cells(2, i), ws.Cells(curLastRow, i))
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
Next i

Application.ScreenUpdating = True

End Sub

Notes:

You'll need to replace "Sheet1" with the correct sheet reference if it changes.
Option Explicit at the top forces you to dimension each variable before it is used. This helps eliminate issues in the future because all variables that you do not dimension are automatically dimensioned as Variant by Excel.

EDIT

Here's a different variation tailored specifically to your workbook (https://i.stack.imgur.com/L7zKY.jpg) that does not rely on finding LastColumn:

Option Explicit

Sub Test2()

Dim ws              As Worksheet
Dim FirstLastRow    As Long
Dim curLastRow      As Long
Dim i               As Long

Application.ScreenUpdating = False

Set ws = ThisWorkbook.Worksheets("Sheet1")
Do Until ws.Cells(1, 8).Value = ""
    For i = 7 To 1 Step -1
        FirstLastRow = ws.Cells(Rows.Count, i).End(xlUp).Row
        curLastRow = ws.Cells(Rows.Count, i + 7).End(xlUp).Row
        ws.Range(ws.Cells(2, i + 7), ws.Cells(curLastRow, i + 7)).Copy ws.Cells(FirstLastRow + 1, i)
        ws.Columns(i + 7).Delete
    Next i
Loop

For i = 1 To 7
    curLastRow = ws.Cells(Rows.Count, i).End(xlUp).Row
    With ws.Sort
        .SortFields.Clear
        .SortFields.Add Key:=ws.Range(ws.Cells(2, i), ws.Cells(curLastRow, i)), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .SetRange ws.Range(ws.Cells(2, i), ws.Cells(curLastRow, i))
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
Next i

Application.ScreenUpdating = True

End Sub

I copied this macro directly into VBA and it did nothing when I ran it. Are there things I need to edit first? http://imgur.com/hGCoWHt Here is a screenshot of a typical file, if that helps. — Ryan, Jan 26 '15 at 17:12
As long as your sheet name is "Sheet1" (which it appears to be), the macro should work. Try stepping through the macro by pressing F8 and see what happens. — TheEngineer, Jan 26 '15 at 17:57
Will your columns always repeat the way they do in the screen shot? i.e. is it always `MD`, `MV`, `TL`, `TV`, `HEAD-DIAM...`, `MAX-DTS`, `RAYBURST-V...`, and then repeat? If so, I could simplify the code. — TheEngineer, Jan 26 '15 at 18:03
Also, the code appears to skip from this line: `For j = LastColumn To i + 1 Step -1` to this line: `LastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column` in the first cycle. — Ryan, Jan 26 '15 at 19:01
What's your value of `LastColumn`? Just put `MsgBox LastColumn` after the variable is defined. — TheEngineer, Jan 26 '15 at 19:14
The last column is just `RAYBURST-VOLUME`. Do you mean to put `MsgBox LastColumn` directly after `LastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column`? Because that didn't seem to work. — Ryan, Jan 26 '15 at 19:21
Yes, put it on the line below that. It should count the total number of columns. — TheEngineer, Jan 26 '15 at 19:22
When I inserted that line under the variable's definition it just displays a messagebox that reads "1" when running the macro. — Ryan, Jan 26 '15 at 19:29
I'm not sure why `LastColumn` is not working properly. However, I've updated my answer to include a second option that does not rely on finding the last column that should work for your workbook. — TheEngineer, Jan 26 '15 at 19:42
No that didn't work either. If this wasn't in my first post, I'm using Excel 2011 for Mac. However I think all of the code you've written should cross over. — Ryan, Jan 27 '15 at 17:46
@Ryan There should be no reason for the second option to fail based on what I saw in the screen shot you posted. Can you upload your file somewhere and post a link so I can check out why it's not working? — TheEngineer, Feb 04 '15 at 20:34

Combining repeating columns

As you can see in the code below, I have frankensteined it with macros I recorded and macros I have found online, as well as some of my own code here and there. It's very ineloquent and lengthy, and I'm sure there's an easier solution.

1 Answers1