excel vba 任意檔案分類

Public myi, myname, myfield




Sub 執行()



myfield = InputBox("請輸入欄號", "中華工程顧問")





排序

分類



For myi = 1 To Sheets.Count - 1



myname = Sheets(myi).name

篩選



資料移轉

排序



Next



還原排序

End Sub



Sub 分類()

Dim newname

my_n = myfield & "2"

Range(my_n).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

my_n = myfield & "2"

Range(my_n).Select

new_col = ActiveCell.Column

Selection.AutoFilter

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





End Sub



Sub 排序()

my_n = myfield & "1"

Sheets(Sheets.Count).Select



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

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

SortMethod:=xlStroke, DataOption1:=xlSortNormal





End Sub



Sub 資料移轉()

複製

開新檔案

貼上

儲存

還原篩選

End Sub



Sub 複製()



Range("a1").Select

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

Selection.Copy



End Sub

Sub 開新檔案()

Workbooks.Add

End Sub



Sub 貼上()



ActiveSheet.Paste

Application.CutCopyMode = False

Selection.Copy

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

:=False, Transpose:=False



End Sub





Sub 儲存()



ActiveWorkbook.SaveAs Filename:= _

"C:\new\" & myname & ".xls", FileFormat:=xlNormal, _

Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _

CreateBackup:=False

ActiveWindow.Close

End Sub



Sub 還原篩選()





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