EXCEL VBA 資料分類

Public myi




Sub 執行()



排序

分類



For myi = 1 To Sheets.Count - 1



篩選

資料移轉

排序



Next



還原排序

End Sub



Sub 分類()

Dim newname



Range("C2").Select

While ActiveCell.Value <> Empty







If ActiveCell.Value = ActiveCell.Offset(1, 0).Value Then



ActiveCell.Offset(1, 0).Select





Else

newname = ActiveCell.Value

Sheets.Add

Sheets(Sheets.Count - 1).name = newname

Sheets(Sheets.Count).Select

ActiveCell.Offset(1, 0).Select

End If







Wend



End Sub

Sub 篩選()

Sheets(Sheets.Count).Select

Range("C2").Select

Selection.AutoFilter

Selection.AutoFilter Field:=3, Criteria1:=Sheets(myi).name





End Sub



Sub 排序()



Sheets(Sheets.Count).Select



Range("A1:I2500").Sort Key1:=Range("C1"), Order1:=xlAscending, Header:= _

xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

SortMethod:=xlStroke, DataOption1:=xlSortNormal





End Sub



Sub 資料移轉()

Range("a1").Select

Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select

Selection.Copy

Sheets(myi).Select

ActiveSheet.Paste

Application.CutCopyMode = False

Selection.Copy

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False



Cells.Select

Cells.EntireColumn.AutoFit



Range("A1").Select

Sheets(Sheets.Count).Select

Application.CutCopyMode = False

Selection.AutoFilter



End Sub

Sub 還原排序()

Sheets(Sheets.Count).Select

Range("A1").Select

Range("A1:I2500").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:= _

xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

SortMethod:=xlStroke, DataOption1:=xlSortNormal

End Sub