EXCEL VBA 公式導入

Sub 授信()


Dim x1, y1, y2, y3

Dim x2, y4



x1 = InputBox("請輸入AI330月份")



y1 = "=ROUND(VLOOKUP(A6,'[AI330-" & x1 & ".xls]Table1'!$A:$F,4,0)/1000,0)"

y2 = "=ROUND(VLOOKUP(A6,'[AI330-" & x1 & ".xls]Table1'!$A:$F,5,0)/1000,0)"

y3 = "=ROUND(VLOOKUP(A6,'[AI330-" & x1 & ".xls]Table1'!$A:$F,6,0)/1000,0)"



x2 = InputBox("請輸入放款結構月份")

y4 = "=ROUND(VLOOKUP('[" & x2 & "放款結構.xls]" & x2 & "結構'!R[26]C1,'[" & x2 & "放款結構.xls]" & x2 & "結構'!C1:C16,5,0)/1000,0)"





Range("J6").Value = y1

Range("J6:J18").Select

Selection.FillDown

Range("J19").Value = "=SUM(J6:J18)"





Range("k6").Value = y2

Range("k6:k18").Select

Selection.FillDown

Range("k19").Value = "=SUM(k6:k18)"



Range("l6").Value = y3

Range("l6:l18").Select

Selection.FillDown

Range("l19").Value = "=SUM(l6:l18)"



Range("J6:L18").Select

Selection.Copy

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

:=False, Transpose:=False



Range("J6").Select



合計





Range("H9").Select

ActiveCell.FormulaR1C1 = y4

Range("H9").Select

Selection.Copy

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

:=False, Transpose:=False



Range("J6").Select



End Sub



Sub 合計()





Range("F6").Value = "=SUM(C6:E6)"

Range("F6").Select

Range(Selection, Selection.End(xlDown)).Select

Selection.FillDown





Range("I6").Value = "=SUM(F6:H6)"

Range("I6").Select

Range(Selection, Selection.End(xlDown)).Select

Selection.FillDown



End Sub

EXCEL VBA合併刪除

Sub 合併()


Dim mymax

Range("B1").Select

mymax = Selection.End(xlDown).Row ' CTRL + 向下的方向鍵

Range("A1").Select





For i = 1 To mymax



If ActiveCell.Value <> Empty Then



ActiveCell.Offset(1, 0).Select



Else



ActiveCell.Offset(-1, 1).Value = ActiveCell.Offset(-1, 1).Value & ActiveCell.Offset(0, 1).Value

Selection.EntireRow.Delete

End If







Next





End Sub



資料結構

編號 品名 數量1 數量2 數量3 日期

1 玩具 5 55 9 1月1日

衣服

股份

書

鞋子

玩具

衣服

2 股份 12 -169 632 1月8日

書

鞋子

玩具

3 鞋子 16 -297 988 1月12日

玩具

鞋子

玩具

鞋子

EXCEL VBA

Sub 資料分割()


流水號

排序

資料搬移

End Sub

Sub 流水號()



Dim mystop



Range("A1").Select

mystop = Selection.End(xlDown).Row



Columns("A:A").Select

Selection.Insert Shift:=xlToRight

Range("A1").Value = "編號"

Range("A2").Value = 1

Range("A2").Select

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

Step:=1, Stop:=mystop - 1, Trend:=False

End Sub

Sub 排序()

Dim mystop, newrng, newname



Range("A1").Select

mystop = Selection.End(xlDown).Row



Range("B1").Select

newrng = "A1:G" & mystop

Range(newrng).Sort Key1:=Range("B1"), Order1:=xlAscending, Header:= _

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

SortMethod:=xlStroke, DataOption1:=xlSortNormal



Range("B2").Select





For i = 1 To mystop - 1



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



newname = ActiveCell.Value

ActiveCell.Offset(1, 0).Select





Else







Sheets.Add

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



Sheets(Sheets.Count).Select

ActiveCell.Offset(1, 0).Select





End If

Next



End Sub

Sub 資料搬移()

'

For i = 1 To Sheets.Count - 1



Sheets(Sheets.Count).Select

Range("A1").Select

Selection.AutoFilter

Selection.AutoFilter Field:=2, Criteria1:=Sheets(i).Name

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

Selection.Copy

Sheets(i).Select

Range("A1").Select

ActiveSheet.Paste

Application.CutCopyMode = False

Sheets(Sheets.Count).Select

Range("A1").Select

Selection.AutoFilter



Next

End Sub

合併與刪除

資料內容如下

十一   消防工程


a          滅火器

1         ABC乾粉滅火器，10型滅火效能A-3.B-

2         ABC乾粉滅火器，20型滅火效能A-5.B-

          30.C

3         ABC乾粉滅火器，50型滅火效能A-8.B-

          30.C

b         室內消防栓箱及採水系統

1         消防泵，額定馬力50HP以下,水量

           1680LPM以上,揚程70M以上

           採水泵，額定馬力50HP以下,水量

           2200LPM以上,揚程56M以上


程式如下


Sub 合併與刪除()


Dim i, j

Dim myrng As Range

Set myrng = Sheets(1).UsedRange

j = myrng.Rows.Count



Range("A1").Select



MsgBox j

For i = 1 To j



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

ActiveCell.Offset(0, 1).Value = ActiveCell.Offset(0, 1).Value & ActiveCell.Offset(1, 1).Value

ActiveCell.Offset(1, 0).Select

Selection.EntireRow.Delete



Else

ActiveCell.Offset(1, 0).Select





End If





Next



Range("A1").Select



End Sub

大家好

大家好歡迎來發言

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

EXCEL _VBA(檔案列表)

Sub 檔案列表()


Dim myPath As String

Dim myFileName As String

Dim i As Long

myPath = ThisWorkbook.Path & "\"
myFileName = Dir(myPath, 0)

i = 1

Do While Len(myFileName) > 0



Cells(i, 1) = myFileName

myFileName = Dir()

i = i + 1

Loop

k = 1

For j = 1 To i

If Right(Cells(j, 1), 3) = "xls" Then

Cells(k, 2) = Cells(j, 1)



k = k + 1



End If

Next

Columns(1).Delete



End Sub


Sub 指定檔案()

Dim myFs As FileSearch

Dim myPath As String

Dim myClc As New Collection

Dim i As Long

Set myFs = Application.FileSearch

myPath = ThisWorkbook.Path
With myFs

.NewSearch

.LookIn = myPath

.FileType = msoFileTypeAllFiles

.Filename = "*.xls"

.SearchSubFolders = True

If .Execute(SortBy:=msoSortByFileName) > 0 Then

For i = 1 To .FoundFiles.Count

If .FoundFiles(i) Like myPath & "*" Then

On Error Resume Next

myClc.Add .FoundFiles(i), .FoundFiles(i)

On Error GoTo 0

End If

Next

End If

End With

Set myFs = Nothing
With myClc

If .Count > 0 Then

For i = 1 To .Count


Cells(i, 1) = Right(.Item(i), Len(.Item(i)) - Len(myPath) - 1)

Next

Else


End If

End With

Set myClc = Nothing
End Sub

網頁設計常用工具

測試網頁區
測試網頁載入時間 - webwait.com
網頁按鈕產生器 - http://www.buttonator.com/
CSS 網頁按鈕 : http://www.pagetutor.com/button_designer/index.html
網頁按鈕 : http://dabuttonfactory.com/
網頁配色工具 : http://0to255.com/
網頁配色 : http://www.colorotate.org/

EXCEL VBA 工作表重新命名

以下用於更新工作表2010為2011的命名
Sub 重新命名()


For i = 1 To Sheets.Count

x = Sheets(i).Name

s = Len(x)

x1 = Left(x, 3) & "1" & Right(x, s - 4)

Sheets(i).Name = x1

Next

End Sub