Method or data member not found (compile error) - excel

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!

Related

Using a macro to move information from one sheet to another

I started learned about the existence of macros yesterday and I know nothing about VBA. This is about to become evident. I am trying to set up a workbook with one sheet as a chemical list and another sheet to load information into it. The list itself will be hidden away to from most people to keep it neat but if someone needs to add a chemical to it they will fill out a form and hit a button and it will load that information into the list. So I recorded the macro below. It is inelegant and has mistakes, I know, but it is just a kind of proof of concept at this stage. But when i run it, it always runs in the sheet I am working on rather than putting the information into the list. Any help?
Sub Insert_Chemical()
'
' Insert_Chemical Macro
'
'
Rows("3:3").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A3").Select
ActiveCell.FormulaR1C1 = "='New Chmical'!RC[1]"
Range("B3").Select
ActiveCell.FormulaR1C1 = "='New Chmical'!RC[1]"
Range("C3").Select
ActiveCell.FormulaR1C1 = "='New Chmical'!RC[1]"
Range("C4").Select
ActiveCell.FormulaR1C1 = ""
Range("D3").Select
ActiveCell.Formula2R1C1 = "='New Chmical'!RC[1]:RC[2]"
Range("E3").Select
ActiveCell.FormulaR1C1 = "='New Chmical'!RC[2]"
Range("D3").Select
ActiveCell.FormulaR1C1 = "='New Chmical'!RC[1]"
Range("F3").Select
ActiveCell.FormulaR1C1 = "='New Chmical'!RC[2]"
Range("G3").Select
ActiveCell.FormulaR1C1 = "='New Chmical'!RC[2]"
Range("H3").Select
ActiveCell.FormulaR1C1 = "='New Chmical'!RC[2]"
Range("I3").Select
ActiveCell.FormulaR1C1 = "='New Chmical'!RC[2]"
Range("F4").Select
ActiveWorkbook.Worksheets("COSHH List").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("COSHH List").AutoFilter.Sort.SortFields.Add2 Key:= _
Range("A1:A4"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("COSHH List").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

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

VBA sort on similar sheets in a workbook without using named sheet based on months that will change based on current month

I need to copy a list from Column C that has blanks throughout the column to Column 0 sorted to remove the blanks. I need to do this on Multiple sheets represent the month (Jan, Feb, Mar, Apr....). The issue I run into is it uses: ActiveWorkbook.Worksheets("Jan") so if I do a do loop to get the other months (Feb, Mar....) then it won't work.
Essentially what I'm trying to get is a master list of all the names in column C from each month for a summary tab listing all the names from the various months. Depending on the month I run this the file will only have sheets for the months that have occurred.
Below is my code:
'First Tab
Columns("C:C").Select
Selection.Copy
Columns("O:O").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
With ActiveWorkbook.Worksheets("Jan").Sort
.SetRange Range("O1:O1590")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
Range("o:o").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort key1:=Range("o:o", Range("o:o").End(xlDown)), _
order1:=xlAscending, Header:=xlNo
'Add the managers to the next sheet
Range("O1").Select
Selection.End(xlUp).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("p1").Select
ActiveSheet.Paste
End With
ActiveSheet.Next.Select
'''''''''''''''''''''
'''''''''''''''''''''
Do
Columns("C:C").Select
Selection.Copy
Columns("O:O").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
With ActiveWorkbook.Worksheets("Jan").Sort
.SetRange Range("O1:O1590")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
Range("o:o").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort key1:=Range("o:o", Range("o:o").End(xlDown)), _
order1:=xlAscending, Header:=xlNo
'Add the names to the next sheet
Range("O1").Select
Selection.End(xlUp).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("p1").Select
' Selection.End(xlDown).Select
' Selection.End(xlUp).Select
ActiveSheet.Paste
ActiveSheet.Previous.Select
Range("O1").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
ActiveSheet.Next.Select
Range("O1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1).Select
ActiveSheet.Paste
Selection.End(xlDown).Select
Selection.End(xlDown).Select
End With
If ActiveSheet.Next.Name = "Summary" Then
Exit Do
ElseIf ActiveSheet.Index <> Sheets.Count Then
ActiveSheet.Next.Select
Else
Exit Do
End If
Loop
ActiveSheet.Next.Select
Range("A1").Select
Sheets("Summary").Select
ActiveSheet.Previous.Select
Columns("O:O").Select
Selection.Copy
ActiveSheet.Next.Select
ActiveWindow.ScrollColumn = 2
Columns("AC:AC").Select
ActiveSheet.Paste
Range("AC2").Select
Selection.End(xlUp).Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.ScrollColumn = 1
Range("A3").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'ActiveSheet.Range("$A$2:$A$43").RemoveDuplicates Columns:=1, Header:=xlYesActiveSheet.Range.Cells("a1").Select
Sheets("Guide").Select
End Sub

You can use Format() to get the worksheet names.
Below is an example of using it for your purpose. You will need to modify your code to work with inputting either the Worksheet name as String or the Worksheet Object itself. sName is what you are stuck on from this post. Example here uses the Worksheet Object Reference.
Option Explicit
Sub ProcessAllMonthsWorksheet()
Dim iMonth As Integer, iYear As Integer, sName As String
Dim oWS As Worksheet
iYear = Year(Date)
On Error Resume Next
For iMonth = 1 To 12
sName = Format(DateSerial(iYear, iMonth, 1), "mmm")
Debug.Print "sName: " & sName
Set oWS = ThisWorkbook.Worksheets(sName)
If Not oWS Is Nothing Then ProcessMonthWorksheet oWS
Set oWS = Nothing
Next
End Sub
Private Sub ProcessMonthWorksheet(ByRef WorksheetObject As Worksheet)
Debug.Print "Processing worksheet """ & WorksheetObject.Name & """"
With WorksheetObject
' do your stuff with the worksheet
End With
End Sub

Adjust all worksheets with the same layout

I'm trying to remove unwanted lines off all the worksheets. For example:
I have multiples worksheets that I need to make a treatment that consist on finding a special character like "-" and remove everything that is above that line, and I mean exclude all lines.
I'm stuck now.. I can't do it properly to apply to all my worksheets and the cell range is different each day.
So far I could do..
Sub Clean()
'
' Clean Macro
'
'
Cells.Select
Selection.AutoFilter
ActiveWorkbook.Worksheets("Sheet1.txt").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1.txt").AutoFilter.Sort.SortFields.Add Key _
:=Range("A1:A66723"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1.txt").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Columns("A:A").Select
Selection.Find(What:="-", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Range("A59044").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireRow.Delete
Selection.End(xlUp).Select
Selection.End(xlUp).Select
End Sub

This works for me:
Sub Clean()
Dim ws As Worksheet
Dim Search As Range
Dim addr As String
For Each ws In Worksheets
ws.Activate
With ws.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Cells
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With ws.Range("A:A")
Set Search = .Find(What:="-", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not Search Is Nothing Then
addr = Search.Address
Else
Exit Sub
End If
End With
Range(addr).Select
ActiveCell.Offset(1, 0).Select
Range(ActiveCell, ActiveCell.End(xlDown)).Select
Selection.EntireRow.Delete
Next
End Sub

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

Resources