EXCEL VBA 資料驗證不限筆數

Sub 驗證()


Dim row_s, row_e, col_s, col_e



row_s = ActiveCell.Row

row_e = ActiveCell.SpecialCells(xlLastCell).Row

col_s = ActiveCell.Column

col_e = ActiveCell.SpecialCells(xlLastCell).Column



For i = 0 To row_e - row_s - 1



For j = 0 To col_e - col_s





If ActiveCell.Value > 0 And ActiveCell.Value < 100 Then

Else

錯誤

End If

ActiveCell.Offset(0, 1).Select

Next



ActiveCell.Offset(0, -j).Select





ActiveCell.Offset(1, 0).Select

Next

End Sub

Sub 錯誤()



Selection.Borders(xlDiagonalDown).LineStyle = xlNone

Selection.Borders(xlDiagonalUp).LineStyle = xlNone

With Selection.Borders(xlEdgeLeft)

.LineStyle = xlContinuous

.Weight = xlThick

.ColorIndex = 3

End With

With Selection.Borders(xlEdgeTop)

.LineStyle = xlContinuous

.Weight = xlThick

.ColorIndex = 3

End With

With Selection.Borders(xlEdgeBottom)

.LineStyle = xlContinuous

.Weight = xlThick

.ColorIndex = 3

End With

With Selection.Borders(xlEdgeRight)

.LineStyle = xlContinuous

.Weight = xlThick

.ColorIndex = 3

End With

End Sub

Sub hjju()

'

' hjju Macro

' Teacher 在 2011/2/26 錄製的巨集

'



'

Range("C3").Select

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

End Sub

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

EXCEL VBA 檔案分類

Public myi, myname




Sub 執行()



排序

分類



For myi = 1 To Sheets.Count - 1



myname = Sheets(myi).name

篩選



資料移轉

排序



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 資料移轉()

複製

開新檔案

貼上

儲存

還原篩選

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

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

EXCEL VBA 合併工作表

Sub 整合資料()


新工作表

轉移

End Sub

Sub 新工作表()



Sheets(1).Select

Range("a1").Select

Sheets.Add

End Sub



Sub 轉移()

Dim i



For i = 2 To Sheets.Count



Sheets(i).Select

If i = 2 Then



Range("a1").Select



Else



Range("a2").Select



End If









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

Selection.Copy

Sheets(1).Select

ActiveSheet.Paste

Selection.End(xlDown).Select

ActiveCell.Offset(1, 0).Select





Next



Range("a1").Select



End Sub

EXCEL VBA 自動流水號

Sub 流水號()
Dim mystart, myend, myrow, myrow1

myrow = ActiveCell.Row

ActiveCell.Offset(0, 1).Select

myrow1 = Selection.End(xlDown).Row

myend = myrow1 - myrow + 1

ActiveCell.Offset(0, -1).Select

mystart = ActiveCell.Value



If mystart <> Empty Then

ActiveCell.Value = mystart

myend = myend - 1


Else

ActiveCell.Value = 1

mystart = 0


End If


Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _

Step:=1, Stop:=myend + mystart, Trend:=False

End Sub

請大家多多指教 我寫的VBA書

EXCEL VBA 書 主要是教大家用錄的巨集 加修改程式
很好用喔 請大家多多指教
看! 就是比你早下班: 50個Excel VBA高手問題解決法

作者 : 楊玉文
 出版社 :松崗電腦圖書資料股份有限公司

出版日期 : 2011/02/15