- 帖子
- 163
- 主題
- 1
- 精華
- 0
- 積分
- 170
- 點名
- 0
- 作業系統
- Window 7
- 軟體版本
- Office 2007
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2010-9-5
- 最後登錄
- 2022-7-20
|
回復 12# Qin
Q1：希望VB 搜尋結果呈現的是由今至遠。
A1：已加寫了，如附件。
Q2：方便在搜尋后, 可以進一步篩選。
A2：不曾寫過這種方式，還是請其他前輩幫忙吧。
陣列的程式碼已加註，請參考：- Private Sub Worksheet_Change(ByVal Target As Range)
- Dim arr '宣告arr為靜態陣列
- Dim brr() '宣告brr為動態陣列
- If Target.Count <> 1 Then Exit Sub '假如Change的儲存格數量不是1個的話退出程序
- If Intersect(Target, [B1:B3]) Is Nothing Then Exit Sub '假如Change的儲存格不是位於B1:B3儲存格中的任一個的話退出程序
- If Target.Value = "" Then '假如Change的儲存格的值是空值得話(被User按了Delete鍵)時....
- Application.EnableEvents = False '取消觸發事件避免因底下的Delete而再次觸發此Change事件
- Rows("4:" & Cells.Rows.Count).Delete '刪除第4列至最底列的舊資料
- Application.EnableEvents = True '恢復觸發事件
- Exit Sub '退出程序
- End If
- ar = Array(6, 7, 4) '將6, 7, 4等關鍵欄位存入ar陣列中
- arr = Sheets("Data").Range("A2:J" & Sheets("Data").[A1].End(4).Row) '將Data工作表內的A2至J欄有資料的最底列存入arr靜態陣列中
- n = 0 'n值存入0
- For i = 1 To UBound(arr) '從1至 arr 1維的最大下標值作為迴圈
- If arr(i, ar(Target.Row - 1)) = Target.Value Then '假如靜態陣列arr中的列i及ar陣列中欄的資料等於Change的儲存格的資料時....
- n = n + 1 'n的值加1
- ReDim Preserve brr(1 To 10, 1 To n) '重新宣告動態陣列brr的一、二維上、下標的數組，以準備存入底下迴圈的資料
- For j = 1 To 10 '因Data欄位總共為10欄，因此迴圈10次來讀取該arr內符合列的資料，存入動態陣列的brr內
- brr(j, n) = arr(i, j) '將上述狀況存入值
- Next j
- End If
- Next i
- If n = 0 Then '假如上述迴圈都找不到資料時....
- MsgBox "於資料庫中並無符合搜尋條件∼", vbCritical + vbOKOnly, "請注意" '彈出訊息警告
- Exit Sub '退出程序
- End If
- Application.EnableEvents = False '取消觸發事件
- For i = 1 To 3 '此迴圈主要處理B1:B3儲存格內的殘存資料
- If Cells(i, 2).Address <> Target.Address Then Cells(i, 2).Value = "" '假如B1:B3儲存格內不是Change的儲存格，則刪除資料
- Next i
- Application.ScreenUpdating = False '將螢幕凍結，以減少畫面的跳動
- Rows("4:" & Cells.Rows.Count).Delete '刪除第4列至最底列的舊資料
-
- [A4].Resize(n, 10) = Application.Transpose(brr) '將存入brr的值轉置後放入以A4儲存格展延n列，10欄的範圍內
- '注意上面的Transpose，因VBA最多只能轉置65536列資料，多了就會產生錯誤，我用的2010版，之後的版本是否有更新不得而知。
-
- Application.ScreenUpdating = False '取消螢幕凍結
- Application.EnableEvents = True '恢復觸發事件
- End Sub
 Book1(範圍物件法加排序).rar (20.56 KB)
|
|
發表於 2018-7-14 19:57
| 
