儲存格設計清單

Private Sub Worksheet_Change(ByVal Target As Range)

x = Left(Target.Address, 2)
If x = "$A" Then
Select Case Target.Value
Case 2
Target.Value = "台北"
Case 3
Target.Value = "桃園"
Case 4
Target.Value = "台中"
Case 5
Target.Value = "嘉義"
Case 6
Target.Value = "台東"
Case 7
Target.Value = "高雄"

End Select


End If

End Sub
Private Sub Worksheet_Change(ByVal Target As Range)

x = Left(Target.Address, 2)
If x = "$C" Then
Select Case Target.Value
Case 1
Target.Value = ActiveCell.Offset(0, -1).Value + ActiveCell.Offset(0, -2).Value

Case 2
Target.Value = (ActiveCell.Offset(0, -1).Value + ActiveCell.Offset(0, -2).Value) / 2
Case 3
Target.Value = ActiveCell.Offset(0, -1).Value - ActiveCell.Offset(0, -2).Value


End Select


End If


End Sub




Private Sub Worksheet_Activate()
Range("b6").FormulaR1C1 = "=SUM(R[-4]C:R[-1]C)"
X = ActiveCell.Value2

ActiveCell.Value = X




End Sub

Private Sub OK_Click() ' 表單元件


ActiveCell.Offset(0, 0).Value = num1.Value
ActiveCell.Offset(0, 1).Value = num2.Value
ActiveCell.Offset(0, 2).Value = num3.Value
ActiveCell.Offset(0, 3).Value = num4.Value
ActiveCell.Offset(1, 0).Select
num1.Value = Empty
num2.Value = Empty
num3.Value = Empty
num4.Value = Empty
num1.SetFocus

End Sub

中華工程 - 新增工作表

Sub 方法一()
Dim mySht As Worksheet
Dim x, y
x = InputBox("請輸入增加工作表的數量", "增加工作表")
For y = 1 To x Step 1
Set mySht = Worksheets.Add(After:=Sheets(Sheets.Count))
With mySht
.Name = y '設定表名
End With
Next y
Set mySht = Nothing '物件的釋放
End Sub

Sub 方法二()
Dim x, y
x = InputBox("請輸入增加工作表的數量", "增加工作表")
With Worksheets
.Add Count:=x '指定張數來新增

End With
End Sub

匯入文件

Public i, j, x, y

Sub 新工作表()
'
' 新工作表 Macro
' gmadmin 在 2010/6/11 錄製的巨集
'

Sheets(1).Select
Sheets.Add
End Sub
Sub 複製()


j = y


For i = 2 To j + 1



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
Application.CutCopyMode = False
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select

Next




End Sub


Public Sub 整合()
新工作表
複製
Range("A1").Select
End Sub
Sub 匯入文字()

y = InputBox("請輸入檔案數量")

For x = 1 To y
新工作表


With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & x & ".txt", Destination:=Range( _
"A1"))
.Name = "1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 950
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With

Next
整合

End Sub

複製 - 中華工程

Sub 新工作表()
'
' 新工作表 Macro
' gmadmin 在 2010/6/11 錄製的巨集
'

Sheets(1).Select
Sheets.Add
End Sub
Sub 複製()

Dim i, j As Integer

j = InputBox("請輸入工作表張數")


For i = 2 To j + 1



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
Application.CutCopyMode = False
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select

Next




End Sub


Public Sub 整合()
新工作表
複製
Range("A1").Select
End Sub

VBA 中華工程

Sub 流水號()

X = ActiveCell.Value
y = InputBox("請輸入結束值")


If X = Empty Then
ActiveCell.Value = 1


Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Stop:=y, Trend:=False

Else
If X <= Int(y) Then

Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Stop:=y + X, Trend:=False

Else


End If

End If


End Sub

Public Function 小計(折扣, 單價, 優惠, 數量)
If 數量 > 5 And 優惠 = "Y" And 單價 > 400 Then
小計 = 單價 * 數量 * (1 - 折扣)
Else

小計 = 單價 * 數量

End If


End Function


Public Function 評語(身高, 體重, 性別)

標準 = 身高 * 身高 * 22 / 10000

If 性別 = 1 Then
標準 = 標準 * 1.1
Else
標準 = 標準 * 0.9
End If

上限 = 標準 * 1.1
下限 = 標準 * (1 - 0.1)


If 體重 > 上限 Then

評語 = "太重"

Else

If 體重 < 下限 Then

評語 = "太輕"

Else

評語 = "太正常"
End If
End If



End Function

東吳出美女

都是大美女

謝謝大家

今天到東吳 不是三國