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