Excel VBA macro with a For loop - excel

I used the following macro which I know is horrible to look at but I was not good enough to integrate a loop in the code so I repeated it.
However, I now need to increase the number of copied columns to 96 and I think it would be much nicer to have a loop...
Here is the current code:
Sub Transpose()
' Transpose Macro
'
'
Application.ScreenUpdating = False
Sheets("HiddenSheet").Visible = True
Sheets("Hiddensheet").Select
Range("A64:T584").Select
Selection.ClearContents
Sheets("Hiddensheet").Select
Range("B2:P61").Select
Selection.Copy
Range("A64").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Range("A64:BH78").Select
Selection.Replace What:="0", Replacement:="", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
ReplaceFormat:=False
Range("A64:BH78").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.Delete Shift:=xlUp
Sheets("Hiddensheet").Select
Range("B64:B78").Select
Selection.Copy
Range("A63").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("C64:C78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("D64:D78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("E64:E78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("F64:F78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("G64:G78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("H64:H78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("I64:I78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("J64:J78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("K64:K78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("L64:L78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("M64:M78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("N64:N78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("O64:O78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("P64:P78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("Q64:Q78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("R64:R78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("S64:S78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("T64:T78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("U64:U78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("V64:V78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("W64:W78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("X64:X78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("Y64:Y78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("Z64:Z78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("AA64:AA78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("AB64:AB78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("AC64:AC78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("AD64:AD78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("AE64:AE78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("AF64:AF78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("AG64:AG78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("AH64:AH78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("AI64:AI78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("AJ64:AJ78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("AK64:AK78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("AL64:AL78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("AM64:AM78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("AN64:AN78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("AO64:AO78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("AP64:AP78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("AQ64:AQ78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("AR64:AR78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("AS64:AS78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("AT64:AT78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("AU64:AU78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("AV64:AV78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("AW64:AW78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("AX64:AX78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("AY64:AY78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("AZ64:AZ78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("BA64:BA78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("BB64:BB78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("BC64:BC78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("BD64:BD78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("BE64:BE78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("BF64:BF78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("BG64:BG78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Hiddensheet").Select
Range("BH64:BH78").Select
Selection.Copy
Range("A64").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Range("A44").End(xlDown).Select
ActiveWorkbook.Worksheets("Hiddensheet").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Hiddensheet").Sort.SortFields.Add(Range("A24").End(xlDown), _
xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(252, _
213, 180)
ActiveWorkbook.Worksheets("Hiddensheet").Sort.SortFields.Add(Range("A24").End(xlDown), _
xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(216, _
228, 188)
ActiveWorkbook.Worksheets("Hiddensheet").Sort.SortFields.Add(Range("A24").End(xlDown), _
xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(230, _
184, 183)
ActiveWorkbook.Worksheets("Hiddensheet").Sort.SortFields.Add(Range("A24").End(xlDown), _
xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(0, _
255, 0)
ActiveWorkbook.Worksheets("Hiddensheet").Sort.SortFields.Add(Range("A24").End(xlDown), _
xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(184, _
204, 228)
ActiveWorkbook.Worksheets("Hiddensheet").Sort.SortFields.Add(Range("A24").End(xlDown), _
xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(204, _
192, 218)
ActiveWorkbook.Worksheets("Hiddensheet").Sort.SortFields.Add(Range("A24").End(xlDown), _
xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(196, _
189, 151)
ActiveWorkbook.Worksheets("Hiddensheet").Sort.SortFields.Add(Range("A24").End(xlDown), _
xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(217, _
217, 217)
ActiveWorkbook.Worksheets("Hiddensheet").Sort.SortFields.Add(Range("A24").End(xlDown), _
xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, _
255, 0)
ActiveWorkbook.Worksheets("Hiddensheet").Sort.SortFields.Add(Range("A24").End(xlDown), _
xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, _
192, 0)
ActiveWorkbook.Worksheets("Hiddensheet").Sort.SortFields.Add(Range("A24").End(xlDown), _
xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(146, _
208, 80)
ActiveWorkbook.Worksheets("Hiddensheet").Sort.SortFields.Add(Range("A24").End(xlDown), _
xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(0, _
176, 80)
ActiveWorkbook.Worksheets("Hiddensheet").Sort.SortFields.Add(Range("A24").End(xlDown), _
xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(0, _
176, 240)
ActiveWorkbook.Worksheets("Hiddensheet").Sort.SortFields.Add(Range("A24").End(xlDown), _
xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, _
0, 0)
ActiveWorkbook.Worksheets("Hiddensheet").Sort.SortFields.Add(Range("A24").End(xlDown), _
xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(112, _
48, 160)
With ActiveWorkbook.Worksheets("Hiddensheet").Sort
.SetRange Range("A64:A963")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Sheets("Hiddensheet").Select
Range("A64:A159").Select
Selection.Copy
Sheets("Import").Select
Range("C2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Import").Select
Range("A2:F97").Select
ActiveWorkbook.Worksheets("Import").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Import").Sort.SortFields.Add Key:=Range("A2:A97") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Import").Sort
.SetRange Range("A2:T97")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1:A97").Select
Selection.Delete Shift:=xlToLeft
Columns("A:F").Select
Cells.EntireColumn.AutoFit
Sheets("HiddenSheet").Visible = False
I need to repeat the part that copies the next column and pastes it at the bottom of the A column 95 times, I would really appreciate some help on the loop.
How could I go about this?


This will copy the columns to the bottom of column A. Just adjust the value that x steps through - currently goes from B to CR.
Edit: I've updated the code to include the other parts in your code. I'm not sure how you're deciding on some ranges so I've left those as is rather than finding the end of the various ranges.
e.g. do you always clear A64:T584 or is it variable?
Public Sub Transpose()
Dim x As Long
Dim rLastCell As Range
Dim shtHidden As Worksheet
Dim shtImport As Worksheet
Set shtHidden = ThisWorkbook.Worksheets("HiddenSheet")
Set shtImport = ThisWorkbook.Worksheets("Import")
With shtHidden
.Visible = xlSheetVisible
.Range("A64:T584").ClearContents
.Range("B2:P61").Copy
.Range("A64").PasteSpecial xlPasteValues
With .Range("A64:BH78")
.Replace What:="0", Replacement:="", _
LookAt:=xlWhole, SearchOrder:=xlByRows
.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End With
For x = 2 To 96 'Adjust to column numbers you want to copy.
Set rLastCell = .Cells(Rows.Count, 1).End(xlUp) 'Last cell containing data in column 1.
.Range(.Cells(64, x), .Cells(78, x)).Copy 'Copy rows 64:78 of column "x".
rLastCell.Offset(1).PasteSpecial xlPasteValues 'Paste values to end of column A.
Next x
Set rLastCell = .Cells(Rows.Count, 1).End(xlUp)
'You seem to be sorting on colour here and then value. Not sure - so only sorted on value.
With .Sort
With .SortFields
.Clear
.Add Key:=shtHidden.Range(shtHidden.Cells(64, 1), rLastCell), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
End With
.SetRange shtHidden.Range(shtHidden.Cells(64, 1), rLastCell)
.Header = xlNo 'Or xlYes
.MatchCase = False
.Orientation = xlTopToBottom
'.SortMethod = xlPinYin 'Something to do with Chinese alphabet, so not needed.
.Apply
End With
'No need to PasteSpecial Values as that was done when copying into column A.
.Range(.Cells(64, 1), rLastCell).Copy Destination:=ThisWorkbook.Worksheets("Import").Range("C2")
End With
With shtImport
With .Sort
With .SortFields
.Clear
.Add Key:=shtImport.Range("A2:A97"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
End With
.SetRange shtImport.Range("A2:T97")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
.Range("A1:A97").Delete Shift:=xlToLeft
.Columns("A:F").AutoFit
End With
shtHidden.Visible = xlSheetHidden 'or xlSheetVeryHidden
End Sub

Related

VBA Autofilter Sheet Name

When applying the macro auto filter, we would like to make it work on the sheet we are currently working on regardless of the sheet.
ActiveWorkBook.Worksheets("sheetname").Sheet.AutoFilter.Sort.SortFields.Clear
-> I changed to
ActiveSheet.AutoFilter.Sort.SortFields.CLEAR
but it does not work.
Sub Name()
Application.ScreenUpdating = False
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
With Application.ReplaceFormat.Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Cells.Replace What:="#N/A", Replacement:="#N/A", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=True
ActiveSheet.AutoFilter.Sort.SortFields.CLEAR
ActiveSheet.AutoFilter.Sort.SortFields.Add(Range( _
"F1:F2000"), xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB( _
255, 255, 0)
With ActiveSheet.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveSheet.Range("$A$1:$S$2000").AutoFilter Field:=6, Criteria1:=RGB(255, _
255, 0), Operator:=xlFilterCellColor
Range("C2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Range("T2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("T2").Select
Application.CutCopyMode = False
ActiveWorkSheet.Range("$A$1:$S$2000").AutoFilter Field:=6
Application.CutCopyMode = False
ActiveSheet.AutoFilter.Sort.SortFields.CLEAR
ActiveSheet.AutoFilter.Sort.SortFields.Add(Range( _
"L1:L2000"), xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color _
= RGB(255, 255, 0)
With ActiveSheet.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveSheet.Range("$A$1:$S$2000").AutoFilter Field:=12, Criteria1:=RGB(255, _
255, 0), Operator:=xlFilterCellColor
Range("I2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Range("U2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("U2").Select
Application.CutCopyMode = False
ActiveSheet.Range("$A$1:$S$2000").AutoFilter Field:=12
Columns("T:U").Select
Application.ReplaceFormat.CLEAR
With Application.ReplaceFormat.Font
.Subscript = False
.TintAndShade = 0
End With
With Application.ReplaceFormat.Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Replace What:="_1", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Range("M2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("M2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=COUNTIF(C[7]:C[8],RC[-11])"
Range("M2").Select
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub

Try this:
Dim Nome_Planilha As String
Nome_Planilha = ActiveSheet.Name
ActiveWorkbook.Worksheets(Nome_Planilha).AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets(Nome_Planilha).AutoFilter.Sort.SortFields.Add Key:= _
Range("A1:A872"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets(Nome_Planilha).AutoFilter.Sort
.Orientation = xlTopToBottom
.Apply
End With

Macro blanking value when only one row in spreadsheet

I have a macro that performs some cleanup on values. It works fine unless there is only one row of data in the spreadsheet; if there is only one row, it blanks out my value instead of fixing it.
Sub UpdateNumberFormat()
Dim LastRow As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Columns("AL:AM").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.NumberFormat = "General"
Range("AL2").Select
ActiveCell.FormulaR1C1 = "'"
Range("AM2").Select
ActiveCell.FormulaR1C1 = "=CONCAT(RC[-1],RC[1])"
Range("AL2:AM" & LastRow).Select
Selection.FillDown
Range("AM2:AM" & LastRow).Select
Selection.Copy
Range("AN2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("AL:AM").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("A1").Select
Columns("C:C").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.NumberFormat = "General"
Range("C2").Select
ActiveCell.FormulaR1C1 = "=TRIM(RC[-1])"
Range("C2:C" & LastRow).Select
Selection.FillDown
Selection.Copy
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("C:C").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("A1").Select
End Sub

Method or data member not found (compile error)

I have a problem with a VBA I recently coded and I have no idea why the error turns up.
The problem is that when I am running the code, it works perfectly fine. When one of my colleagues runs the code, it's perfectly fine as well. But there are some older colleagues and when they try to run the code there's the error message mentioned above.
Do you think it appears because of their older equipment or what would you suggest?
Here's the code:
Sub Datenauswerten()
Application.ScreenUpdating = False
Sheets("Auswertung").Visible = True
Sheets("Auswertung").Select
Range("A1:D100").Select
Selection.ClearContents
Sheets("Pivot").Select
Range("B6").Select
ActiveWorkbook.RefreshAll
Range("D7").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Selection.Copy
Sheets("Auswertung").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Sheets("Auswertung").Range("b1").Value = "Kategorie"
Sheets("Auswertung").Range("c1").Value = "Störung"
Sheets("Auswertung").Range("d1").Value = "Dauer [h]"
Cells.Select
Cells.EntireColumn.AutoFit
Range("D1").Select
ActiveWorkbook.Worksheets("Auswertung").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Auswertung").Sort.SortFields.Add
Key:=Range("D1"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Auswertung").Sort
.SetRange Range("A2:D100")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A5:D100").Select
Selection.ClearContents
Range("A:A").Select
Selection.ClearContents
Columns("D:D").Select
Selection.NumberFormat = "0.00"
Sheets("Auswertung").Range("b1").Value = "Kategorie"
Sheets("Auswertung").Range("c1").Value = "Störung"
Sheets("Auswertung").Range("d1").Value = "Dauer [h]"
Sheets("Auswertung").Range("A1").Select
Sheets("Grafik").Select
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.FullSeriesCollection(1).Values = "=Auswertung!$D$2:$D$4"
ActiveChart.FullSeriesCollection(1).XValues = "=Auswertung!$B$2:$C$4"
Sheets("Auswertung").Select
Range("A50").Select
Sheets("Auswertung").Visible = False
Application.ScreenUpdating = True
End Sub
Thank you very much for your help!

Combining repeating columns

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

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 (http://imgur.com/hGCoWHt) 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

calculating network days, with some dates omitted from exceptions - Excel

The following is a macro which collects data from data we import into certain tabs. When the macro is run it filters through the data and produces a new excel book with this new data. The person who created this is no longer with us. The macro works fine except I'm trying to add another column like the one that calculates network days called days since 1st auth less parked. Im wanting to add another which gives days since the start of the information being passed to us. Ie a column call 1st instructed less parked.
Sub Runme()
'
' Macro1 Macro
' Macro recorded 22/03/2013'
'
Sheets("CCX data SORTED").Select
Cells.Select
Selection.Delete Shift:=xlUp
Sheets("CCX Data Raw").Select
Range("A:C,E:G").Select
Selection.Delete Shift:=xlToLeft
Rows("1:1").Select
Selection.AutoFilter
Range("H2").Select
Range("A1:X10000").Sort Key1:=Range("H1"), Order1:=xlDescending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("H55000").End(xlUp)(2, 1).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Selection.ClearContents
Cells.Select
Selection.Copy
Sheets("CCX data SORTED").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("CCX Data Raw").Select
Cells.Select
Selection.Delete Shift:=xlUp
Sheets("CCX data SORTED").Select
Columns("X:X").Select
Selection.Insert Shift:=xlToRight
Range("X2").Select
ActiveCell.FormulaR1C1 = _
"=IF(VLOOKUP(RC[-23],'SCMT weekly data'!C[-17]:C[-11],7,FALSE)>0,(VLOOKUP(RC[-23],'SCMT weekly data'!C[-17]:C[-11],7,FALSE)),"""")"
Range("X2").Select
Selection.AutoFill Destination:=Range("X2:X5000")
Range("X1").Select
ActiveCell.FormulaR1C1 = "SCMT end Date"
Columns("X:X").Select
Selection.NumberFormat = "m/d/yyyy"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("SCMT Weekly data").Select
Columns("Z:Z").Select
Selection.Insert Shift:=xlToRight
Range("Z1").Select
ActiveCell.FormulaR1C1 = "Days To Exclude 1"
Range("Z2").Select
ActiveCell.FormulaR1C1 = _
"=IF(COUNTA(RC[-2],RC[-1])=2,NETWORKDAYS(RC[-2],RC[-1],'Bank hols'!RC[-25]:R[56]C[-25]),0)"
Selection.AutoFill Destination:=Range("Z2:Z5000"), Type:=xlFillDefault
Columns("AD:AD").Select
Selection.Insert Shift:=xlToRight
Range("AD1").Select
ActiveCell.FormulaR1C1 = "Days To Exclude 2"
Range("AD2").Select
ActiveCell.FormulaR1C1 = _
"=IF(COUNTA(RC[-2],RC[-1])=2,NETWORKDAYS(RC[-2],RC[-1],'Bank hols'!RC[-29]:R[56]C[-29]),0)"
Selection.AutoFill Destination:=Range("AD2:AD5000")
Columns("Z:Z").Select
Selection.NumberFormat = "0"
Columns("AD:AD").Select
Selection.NumberFormat = "0"
Range("AH2").Select
ActiveCell.FormulaR1C1 = "=TODAY()"
Range("AF1").Select
ActiveCell.FormulaR1C1 = "Days since first auth"
Range("AF2").Select
ActiveCell.FormulaR1C1 = _
"=IF(COUNTA(RC[-21],R2C34)=2,NETWORKDAYS(RC[-21],R2C34,'Bank hols'!RC[-31]:R[56]C[-31]),"""")"
Range("AG2").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISNUMBER(RC[-1]),SUM(RC[-1]-(RC[-3]+RC[-7])),"""")"
Range("AG1").Select
ActiveCell.FormulaR1C1 = "Days since 1st Auth less parked"
Columns("AH:AH").Select
Selection.Insert Shift:=xlToRight
Range("AH1").Select
ActiveCell.FormulaR1C1 = "Still Parked"
Range("AH2").Select
ActiveCell.FormulaR1C1 = _
"=IF(AND(ISNUMBER(RC[-10]),ISBLANK(RC[-9])),""XX"",IF(AND(ISNUMBER(RC[-6]),ISBLANK(RC[-5])),""XX"",""""))"
Selection.AutoFill Destination:=Range("AH2:AH5000")
Range("AF2:AG2").Select
Selection.AutoFill Destination:=Range("AF2:AG5000")
Range("A55000").End(xlUp)(2, 1).Select
Selection.EntireRow.Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Sheets("CCX data SORTED").Select
Range("Z1").Select
ActiveCell.FormulaR1C1 = "SCMT Queue"
Range("Z2").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-25],'SCMT Daily Drop'!C[-16]:C[-14],3,FALSE)"
Selection.AutoFill Destination:=Range("Z2:Z5000")
Range("AA1").Select
ActiveCell.FormulaR1C1 = "Days Since First Approved"
Range("AA2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1,'SCMT weekly data'!C7:C34,27,FALSE)"
Selection.AutoFill Destination:=Range("AA2:AA5000")
Range("AB1").Select
ActiveCell.FormulaR1C1 = "Still Parked"
Range("AB2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1,'SCMT weekly data'!C7:C34,28,FALSE)"
Selection.AutoFill Destination:=Range("AB2:AB5000")
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A55000").End(xlUp)(2, 1).Select
Selection.EntireRow.Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Sheets("SCMT weekly data").Select
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets(Array("SCMT weekly data", "SCMT Daily Drop", "CCX data SORTED")).Select
Sheets("CCX data SORTED").Activate
Sheets(Array("SCMT weekly data", "SCMT Daily Drop", "CCX data SORTED")).Copy
Windows("SCMT Parked.xls").Activate
Sheets("SCMT weekly data").Select
Cells.Select
Selection.Delete Shift:=xlUp
Sheets("SCMT Daily Drop").Select
Cells.Select
Selection.Delete Shift:=xlUp
Sheets("CCX data SORTED").Select
Cells.Select
Selection.Delete Shift:=xlUp
MsgBox ("Macro Complete")
End Sub

Where do you want it? IF you want it in the z column, for example, try:
Columns("Z:Z").Select
Selection.Insert Shift:=xlToRight
Range("Z1").Select
ActiveCell.FormulaR1C1 = "New formula"
Range("Z2").Select
ActiveCell.FormulaR1C1 = "=AA2-AB2"
Selection.AutoFill Destination:=Range("Z2:Z5000")
I don't understand the formula you need, but there's a template you can use... If you give us the formula we can put it the second last line?

Resources