Qin

回復 8# faye59

由於是 VBA 菜鳥的關係, 雖然,一直以來也有看看各路高手在此論壇的貼文,
如: GBKEE 版主用心的在程序碼上寫上註解. 也許,不是自己發出的提問, 看後也是似懂非懂.

你所上載2篇程式碼, 由於我的電腦是英文系統, 皆屬亂碼.
在此希望你能將這2篇程式碼貼在留言版上.讓我可以解讀並收下研究. 謝謝!!

下載 (62.52 KB)

2018-7-15 15:25

   



我心存迷惘, 因為對 VBA 的一知半解, 當我在網上發問時, 我遇到了一群熱心幫助我的人.

Qin

回復 10# Kubi

你上載的範圍物件法, 非常適用.

如果可以, 可否幫我修改以下2個問題...
1)        Data (資料庫)里的資料如果是日期由遠至今. ( 22/05/2015 -  22/05/2017) 希望VB 搜尋結果呈現的是由今至遠.
2)        Search (搜尋) 里的 Row 4 可否增加 Filter, 方便在搜尋后, 可以進一步篩選. (如: 薯條, 薯泥, 薯片)

P/s: 由於亂碼的關係, 你上載的"列陣法”我不能完全的解讀, 可否也請你將它貼在留言板上.  無限感激.

faye59

回復 11# Qin


   
搜尋資料.xlsm

1. Sub 搜尋表單()
   
2. Dim F1, F2 As Variant
   
3. F1 = Sheets("搜尋").Range("B1")
   
4. Sheets("搜尋").Select
   
5. Sheets("搜尋").Range([A3], [J3].End(xlDown)) = ""
   
6. If F1 = "" Then
   
7. 
   
8. MsgBox "您未輸入條件"
   
9. Exit Sub
   
10. End If
    
11. 
    
12. For I = 2 To Sheets("資料庫").UsedRange.Rows.Count
    
13. If Sheets("資料庫").Cells(I, 4) = F1 Or Sheets("資料庫").Cells(I, 6) = F1 Or Sheets("資料庫").Cells(I, 7) = F1 Then
    
14. Worksheets("資料庫").Range("A" & I, "J" & I).Copy Destination:=Worksheets("搜尋").Range("A" & Application.CountA(Sheets("搜尋").Columns("A:A")) + 1)
    
15. End If
    
16. Next I
    
17. 
    
18. MsgBox "您輸入" & "條件" & "[ " & F1 & " ]" & "共計" & Application.CountA(Sheets("搜尋").Columns("A:A")) - 2 & "筆資料"
    
19. 
    
20. End Sub

複製代碼

搜索資料1

1. Sub Serach()
   
2. Application.DisplayAlerts = False
   
3. Application.ScreenUpdating = False
   
4. Dim a, b, c As String
   
5. Dim f1, f2, f3 As Workbook
   
6. 
   
7. Set f1 = Sheets("資料庫")
   
8. Set f2 = Sheets("搜尋資料")
   
9. a = Application.InputBox("請輸入查詢的項目代碼:1.公司 2.編號 3.品名", "輸入搜尋項目")
   
10. b = Application.InputBox("請輸入查詢的內容名稱", "輸入搜尋內容")
    
11. If a = "" Or a = False Or b = "" Or b = False Then
    
12. Exit Sub
    
13. Else
    
14. Select Case a
    
15. Case "1"
    
16.     X = 3
    
17. Case "2"
    
18.     X = 5
    
19. Case "3"
    
20.     X = 6
    
21. Case Else
    
22. Exit Sub
    
23. End Select
    
24. f1.Select
    
25. For Each aa In Range([A2], [A2].End(xlDown))
    
26. If aa.Offset(, X) = b Then
    
27.     f2.Select
    
28.     n = n + 1
    
29.     NextRow = Cells(Rows.Count, 2).End(xlUp).Row + 1
    
30.     Cells(NextRow, 1) = n
    
31.     Cells(NextRow, 2).Resize(1, 9) = aa.Offset(0, 1).Resize(1, 9).Value
    
32.     Cells(NextRow, 15).Resize(1, 1) = aa.Offset(0, 0).Resize(1, 1).Value
    
33. End If
    
34. Next
    
35. End If
    
36. f2.Cells(1, 15) = "total: " & Application.CountA(f2.Range("A:A")) - 1
    
37. f2.Select
    
38. Application.DisplayAlerts = True
    
39. Application.ScreenUpdating = True
    
40. End Sub

複製代碼

1. Sub clase()
   
2. [A3:O60000] = ""
   
3. [O1] = "total: 0"
   
4. End Sub

複製代碼

Kubi

回復 12# Qin
Q1：希望VB 搜尋結果呈現的是由今至遠。
A1：已加寫了，如附件。

Q2：方便在搜尋后, 可以進一步篩選。
A2：不曾寫過這種方式，還是請其他前輩幫忙吧。

陣列的程式碼已加註，請參考：

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Dim arr     '宣告arr為靜態陣列
   
3.     Dim brr()   '宣告brr為動態陣列
   
4.     If Target.Count <> 1 Then Exit Sub  '假如Change的儲存格數量不是1個的話退出程序
   
5.     If Intersect(Target, [B1:B3]) Is Nothing Then Exit Sub      '假如Change的儲存格不是位於B1:B3儲存格中的任一個的話退出程序
   
6.     If Target.Value = "" Then       '假如Change的儲存格的值是空值得話(被User按了Delete鍵)時....
   
7.         Application.EnableEvents = False        '取消觸發事件避免因底下的Delete而再次觸發此Change事件
   
8.         Rows("4:" & Cells.Rows.Count).Delete    '刪除第4列至最底列的舊資料
   
9.         Application.EnableEvents = True     '恢復觸發事件
   
10.         Exit Sub    '退出程序
    
11.     End If
    
12.     ar = Array(6, 7, 4)     '將6, 7, 4等關鍵欄位存入ar陣列中
    
13.     arr = Sheets("Data").Range("A2:J" & Sheets("Data").[A1].End(4).Row)     '將Data工作表內的A2至J欄有資料的最底列存入arr靜態陣列中
    
14.     n = 0   'n值存入0
    
15.     For i = 1 To UBound(arr)    '從1至 arr 1維的最大下標值作為迴圈
    
16.         If arr(i, ar(Target.Row - 1)) = Target.Value Then   '假如靜態陣列arr中的列i及ar陣列中欄的資料等於Change的儲存格的資料時....
    
17.             n = n + 1   'n的值加1
    
18.             ReDim Preserve brr(1 To 10, 1 To n)     '重新宣告動態陣列brr的一、二維上、下標的數組，以準備存入底下迴圈的資料
    
19.             For j = 1 To 10     '因Data欄位總共為10欄，因此迴圈10次來讀取該arr內符合列的資料，存入動態陣列的brr內
    
20.                 brr(j, n) = arr(i, j)   '將上述狀況存入值
    
21.             Next j
    
22.         End If
    
23.     Next i
    
24.     If n = 0 Then   '假如上述迴圈都找不到資料時....
    
25.         MsgBox "於資料庫中並無符合搜尋條件～", vbCritical + vbOKOnly, "請注意"      '彈出訊息警告
    
26.         Exit Sub    '退出程序
    
27.     End If
    
28.     Application.EnableEvents = False    '取消觸發事件
    
29.     For i = 1 To 3  '此迴圈主要處理B1:B3儲存格內的殘存資料
    
30.         If Cells(i, 2).Address <> Target.Address Then Cells(i, 2).Value = ""    '假如B1:B3儲存格內不是Change的儲存格，則刪除資料
    
31.     Next i
    
32.     Application.ScreenUpdating = False      '將螢幕凍結，以減少畫面的跳動
    
33.     Rows("4:" & Cells.Rows.Count).Delete    '刪除第4列至最底列的舊資料
    
34.    
    
35.     [A4].Resize(n, 10) = Application.Transpose(brr) '將存入brr的值轉置後放入以A4儲存格展延n列，10欄的範圍內
    
36.     '注意上面的Transpose，因VBA最多只能轉置65536列資料，多了就會產生錯誤，我用的2010版，之後的版本是否有更新不得而知。
    
37.    
    
38.     Application.ScreenUpdating = False  '取消螢幕凍結
    
39.     Application.EnableEvents = True         '恢復觸發事件
    
40. End Sub

複製代碼

Book1(範圍物件法加排序).rar (20.56 KB)

下載次數: 9

2018-7-15 20:28

Qin

回復 14# Kubi


    有疑問, 再次勞煩....

    Book1(範圍物件法加排序).rar (26.15 KB)

下載次數: 5

2018-7-18 21:10

Kubi

回復 15# Qin

請參考
Book1(範圍物件法加排序)-1.rar (26.06 KB)

下載次數: 9

2018-7-19 20:34

Qin

回復 16# Kubi


    謝謝....

Qin

回復 16# Kubi



     再次勞煩..
     當我使用 filter 篩選後, 沒有還原, 接下來再搜尋資料, 就會 Debug
  
     

下載 (17.66 KB)

2018-7-19 23:18

     

下載 (11.02 KB)

2018-7-19 23:19

Kubi

回復 18# Qin

試看看
Book1(範圍物件法加排序)-2.rar (26.14 KB)

下載次數: 15

2018-7-20 20:10

Qin

回復 19# Kubi


    可以了... Thanks