VBALesson 9 程式說明∶體會一下Worksheet_Change()事件連鎖反應。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim iRow As Integer
iRow = Target.Row
Application.EnableEvents = False
Cells(iRow, 3) = Cells(iRow, 3) + Cells(iRow, 2)
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim iRow As Integer
iRow = Target.Row
'Application.EnableEvents = False
Cells(iRow, 3) = Cells(iRow, 3) + Cells(iRow, 2)
'Application.EnableEvents = True
End Sub
這個程式的目的是要在 B2 輸入新的數?時，C2 會將 B2 輸入的新數?加上 C2 原
有的數?呈現在 C2 上。
照上面有加上 Application.EnableEvents = False 程式執行當然沒問題。
現在你在 Application.EnableEvents = False 與 Application.EnableEvents =
True 前加上「 '」看看。
程式前加上「 '」的目的是要使「 '」之後的文字變成說明文字，程式執行時是會跳
過說明文字，不執行說明文字的內容。
程式前加上「 '」符號後，文字會變成綠色。
執行第二個程式時，你將發現 C2 不會按你所要求的，呈現結果。
這就是所謂的事件連鎖反應。
請問這個宏該如何寫!
我想運行一個宏,就能在當前工作表B3上填上一條公式;這條公式的結果是所有工作
表上的B4單元格的和.請問這個宏該如何寫.謝謝!
Sub gg()
Dim sh As Worksheet, shname$
For Each sh In Worksheets
shname = sh.Name
ActiveSheet.Range("b3").value = ActiveSheet.Range("b3").value +
Worksheets(shname).Range("b4")
Next
End Sub
VBA中怎樣創建一個名爲“table”的新工作表
通過VBA編程，很容易添加新的工作表，但是新表的名字不知怎樣控制，對於新創建
的工作表，由於其名字並非特定，所以就不好使用所創建的新表了。不知各位有何高
見。。。。
Sheets.Add
ActiveSheet.Name = "table"
請教：如何用VBA檢索表1中A列與表2，3，4，5.....中A列相同的行並把後者整行拷
貝到表1檢索到的行中,謝謝!!!!
To yxptwq∶用這程式試看看。
Sub Copy1()
Dim Row_dn1, Row_dnN, i, j, n As Integer
Row_dn1 = Sheet1.Range("A65536").End(xlUp).Row
k = 1: n = 1
For Each wSheet In ActiveWorkbook.Worksheets
With wSheet
If .Name "Sheet1" Then
Row_dnN = .Range("A65536").End(xlUp).Row
For i = 2 To Row_dn1
For j = 2 To Row_dnN
If .Cells(j, 1) = Sheet1.Cells(i, 1) Then
.Rows(j & ":" & j).Copy Destination:=Sheet1.Rows(Row_dn1 +
n & ":" & Row_dn1 + n)
n = n + 1
End If
Next j
Next i
End If
End With
Next wSheet
End Sub
如果要用VBA程式輸入密碼使用下列程式碼
Sub EnterNewPW()
'程式說明:利用SendKey輸入VBAProject密碼
'注意事項:執行本程式需要在Excel視窗,不能在VBE視窗
Application.SendKeys "%{F11}", True 'Alt + F11 切換到VBA視窗
Application.SendKeys "%T", True 'ALT + T 工具(繁體中文是(T))
Application.SendKeys "e", True '工具(T)-VBproject屬性(E)
Application.SendKeys "^{TAB}", True 'TAB 鍵(切換到PAge2 保護頁面)
Application.SendKeys "{+}", True '選取Checkbox方塊(鎖定專案以供檢
視)
'({+} 選取, {-} 取消選取)
Application.SendKeys "{TAB}", True 'TAB 鍵(跳到第一次輸入密碼
Textbox
myPW = "chijanzen" '假設密碼 chijanzen
Application.SendKeys myPW, True '輸入密碼
Application.SendKeys "{TAB}", True 'TAB 鍵(跳到第二次輸入密碼
Textbox
Application.SendKeys myPW, True '輸入密碼
Application.SendKeys "{ENTER}", True '按確定鈕(預設值)
Application.SendKeys "%{F11}", True '返回Excel視窗
End Sub
冒泡排序法：
冒泡排序法之所以成爲“冒泡排序”是因爲值較小的或是較輕的元素浮到作爲繼續排
序的一組數的頂部。
Sub Macro1()
Dim i As Integer
Dim j As Integer
Dim t as integer
Static number(1 To 10) As Integer
For i = 1 To 10
number(i) = inputbox“輸入要排序的數：”
Next i
For i = 10To 2 Step -1
For j = 1 To i – 1
‘下面進行位置交換
If number(j) > number(j + 1) Then
t = number(j + 1)
number(j + 1) = number(j)
number(j) = t
End If
Next j
Next i
For i = 1 To 20
Print number(i)
Next i
End sub
首先定義一個數組：通過循環錄入10個整數，然後用一個二重循環測試前一個數是否
大於後一個數。如果大於則交換兩個數的下標，即交換兩個數在數組中的位置，交換
通過一個變量來進行。
我先用傳統的方法解決這個問題，經過比較，選用了較爲簡單的和高效的排序方法
——“快速排序”，具體演算法可參考數據結構等有關書籍。對所有數據排序後再合
並相同數據，合並程式較爲簡便，我開始時採用了這種方法，但後來發現對於這些
的數據，先合並後排序速度更快，因爲有大量相同的數據。合並是採用“標記”算
法，具體如下：（設數據已存放在sData()數組中 ，結果存到Queryp()數組，
Amount是數據個數）
'把相同元素置 0
For i = 1 To Amount
If sData(i) 0 Then
For j = i ＋ 1 To Amount
If sData(i) = sData(j) Then sData(j) = 0
Next j
End If
Next i
'刪除相同元素
Queryp(1) = sData(1)
k = 1
For i = 2 To Amount
If Not (sData(i) = 0) Then
k = k ＋ 1
Queryp(k) = sData(i)
End If
Next i
kMax = k
ReDim Preserve Queryp(kMax)
雖然這樣使得運算速度有所高，但是仍然要進行大量的循環運算，占據了程式大部
分的運算時間。於是我一直在尋覓一種更爲高效的演算法。
功夫不負有心人，在仔細分析數據的特徵，比較了多種方案之後，我終於找到了一
種相當成功的演算法，原來要3到4秒的運算縮短到僅需0.1到0.2秒。
我遇到的數據具有以下特徵：①相同數據很多，②最大、最小數之間相差不到3，
③都是帶兩位小數的正數。
針對數據的特徵，我採用了以下演算法：
針對數據的特徵，我採用了以下演算法：
步驟：
1． 用一個循環找出整數和小數部分的最大、最小值。小數部分的最大、最小值乘
以100轉爲整數。
2． 定義一個二維數組，下標範圍分別是整數和小數部分的最小值到最大值。
3． 再用一個循環把所有源數據填入剛才定義的二維數組，填寫規則是，源數據的
整數和小數部分分別對應二維數組的兩個下標。例如，“13.51"填到“A(13,51)"
中。
4． 最後順向或逆向讀取二維數組中的非零數據即可得到從小到大或從大到小排列
的數據，而且不會含有重複數據。
用VB 編寫的程式如下：
'＊＊＊＊密集型數據處理＊＊＊＊
Dim i As Long, j As Long, k As Long, kMax As Long
Dim Queryp() As Single
ReDim Queryp(Amount)
Dim IntegerPart As Integer, DecimalPart As Integer
Dim IPmax As Integer, IPmin As Integer
Dim DPmax As Integer, DPmin As Integer
Dim DiffDataArray()
'讀取數據
ReadData
IPmax = 0: IPmin = 1000
DPmax = 0: DPmin = 99
For i = 1 To Amount
' 找整數和小數部分的最大、最小值
IntegerPart = Int(sData(i))
DecimalPart = (sData(i) － IntegerPart) ＊ 100
If IntegerPart > IPmax Then
IPmax = IntegerPart
ElseIf IntegerPart DPmax Then
DPmax = DecimalPart
ElseIf DecimalPart 0 Then
k = k ＋ 1
Queryp(k) = DiffDataArray(i, j)
End If
Next j
Next i
kMax = k
ReDim Preserve Queryp(kMax)
該方法對於本人遇到的這種“密集型”數據最爲有效，但是如果遇上“稀疏型”數
據，例如最大、最小值相差幾千，甚至上萬的數據，就沒什麽優勢了，而且會佔用
較大的內存。
經過改進，我得到了處理稀疏型數據的高效演算法。高效的前提條件同樣是源數據具
有大量相同數據。思路是在前一種方法的基礎上增加一個單維數組，用來保存整數
部分數據，保存過程中用插入法對其進行排序。因爲有大量重複數據，要排序的數
據量相對較少。當從二維數組中讀取數據時，用單維數組代入二維數組的第一個下
標，具體代碼下：
'＊＊＊＊稀疏型數據處理＊＊＊＊
Dim i As Long, j As Long, k As Long, kMax As Long
Dim Queryp() As Single
ReDim Queryp(Amount)
Dim IntegerPart As Integer, DecimalPart As Integer
Dim IPmax As Integer, IPmin As Integer
Dim DPmax As Integer, DPmin As Integer
Dim IPArray() As Integer, IPAamount As Integer
ReDim IPArray(Amount)
Dim DiffDataArray()
'讀取數據
ReadData
IPmax = 0: IPmin = 1000
DPmax = 0: DPmin = 99
IPAamount = 0
For i = 1 To Amount
'獲取整數和小數部分的最大最小值
IntegerPart = Int(sData(i))
DecimalPart = (sData(i) － IntegerPart) ＊ 100
If IntegerPart > IPmax Then
IPmax = IntegerPart
ElseIf IntegerPart DPmax Then
DPmax = DecimalPart
ElseIf DecimalPart IPArray(j) Then
IPAamount = IPAamount ＋ 1
For k = IPAamount To j ＋ 1 Step －1
IPArray(k) = IPArray(k － 1)
Next k
IPArray(j) = IntegerPart
Exit For
ElseIf IntegerPart = IPArray(j) Then
Exit For
End If
Next j
If j > IPAamount Then
IPAamount = IPAamount ＋ 1
IPArray(IPAamount) = IntegerPart
End If
Next i
ReDim DiffDataArray(IPmin To IPmax, DPmin To DPmax)
'填入數據
For i = 1 To Amount
IntegerPart = Int(sData(i))
DecimalPart = (sData(i) － IntegerPart) ＊ 100
DiffDataArray(IntegerPart, DecimalPart) = sData(i)
Next i
'提取數據
k = 0
For i = 1 To IPAamount
For j = DPmax To DPmin Step －1
If DiffDataArray(IPArray(i), j) 0 Then
k = k ＋ 1
Queryp(k) = DiffDataArray(IPArray
（i), j)
End If
Next j
Next i
kMax = k
ReDim Preserve Queryp(kMax)
k
ReDim Preserve Queryp(kMax)
自動隱藏表格中無數據的行
表1 是數據源，經常改變；
表2 引用表1 中某列有數據的單元格（利用動態位址已實現。）
由於表1 的改變，表2 的大小隨之而變。
問題：如何實現表2 中沒有數據的行（有公式）自動隱藏？謝謝賜教！
Sub abc()
For i = 1 To 300
If Cells(i, 1).value = "" Then Rows(i).Hidden = True
Next i
End Sub
你寫的語句可以解決隱藏的問題，可是如果我執行了它之後，再在表1中增加數據，
表2不會自動顯示有了數據的行。如何修改？
將此宏設爲自動運行（打開文件時）
Sub abc()
For i = 1 To 300
If Cells(i, 1).value "" Then Rows(i).Hidden = false
Next i
End Sub
用VBA如何自動合並列的內容？
用VBA如何自動合並列的內容？
To hongjian ：
Sub MergeTest()
For i = 3 To 30
Cells(i, 3) = Cells(i, 1) & Chr(10) & Cells(i, 2)
Next
End Sub
相關閱讀...
Excel VBA 使用函數範例參考之一
Excel VBA 使用函數範例參考之二
Excel VBA 使用函數範例參考之四
Excel VBA 使用函數範例參考之五
Excel VBA 使用函數範例參考之六
沒有留言:
張貼留言