VBA 資料搜尋問題

帖子: 207
主題: 61
精華: 0
積分: 270
點名: 0
作業系統: Vista
軟體版本: office2003
閱讀權限: 20
性別: 女
註冊時間: 2011-3-20
最後登錄: 2023-6-25

11^# 跳轉到 »

發表於 2018-7-15 15:27 | 只看該作者

回復 8# faye59

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

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

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

TOP

Qin

中學生 Rank: 2

帖子: 207
主題: 61
精華: 0
積分: 270
點名: 0
作業系統: Vista
軟體版本: office2003
閱讀權限: 20
性別: 女
註冊時間: 2011-3-20
最後登錄: 2023-6-25

12^#

發表於 2018-7-15 15:39 | 只看該作者

回復 10# Kubi

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

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

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

TOP

faye59

　暱稱: 温奇
　頭銜: 議論者

中學生 Rank: 2

帖子: 104
主題: 5
精華: 0
積分: 110
點名: 0
作業系統: win7
軟體版本: Office2007
閱讀權限: 20
性別: 男
註冊時間: 2017-11-14
最後登錄: 2019-4-30

論壇榮譽勳章論壇贊助勳章

13^#

發表於 2018-7-15 19:39 | 只看該作者

回復 11# Qin

搜尋資料.xlsm

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

複製代碼

搜索資料1

Sub Serach()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim a, b, c As String
Dim f1, f2, f3 As Workbook
Set f1 = Sheets("資料庫")
Set f2 = Sheets("搜尋資料")
a = Application.InputBox("請輸入查詢的項目代碼:1.公司 2.編號 3.品名", "輸入搜尋項目")
b = Application.InputBox("請輸入查詢的內容名稱", "輸入搜尋內容")
If a = "" Or a = False Or b = "" Or b = False Then
Exit Sub
Else
Select Case a
Case "1"
X = 3
Case "2"
X = 5
Case "3"
X = 6
Case Else
Exit Sub
End Select
f1.Select
For Each aa In Range([A2], [A2].End(xlDown))
If aa.Offset(, X) = b Then
f2.Select
n = n + 1
NextRow = Cells(Rows.Count, 2).End(xlUp).Row + 1
Cells(NextRow, 1) = n
Cells(NextRow, 2).Resize(1, 9) = aa.Offset(0, 1).Resize(1, 9).Value
Cells(NextRow, 15).Resize(1, 1) = aa.Offset(0, 0).Resize(1, 1).Value
End If
Next
End If
f2.Cells(1, 15) = "total: " & Application.CountA(f2.Range("A:A")) - 1
f2.Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

複製代碼

Sub clase()
[A3:O60000] = ""
[O1] = "total: 0"
End Sub

複製代碼

一分努力，一分收穫。
發問題前可以先搜索內文是否有相關範例。

TOP

Kubi

中學生 Rank: 2

帖子: 163
主題: 1
精華: 0
積分: 170
點名: 0
作業系統: Window 7
軟體版本: Office 2007
閱讀權限: 20
性別: 男
註冊時間: 2010-9-5
最後登錄: 2022-7-20

14^#

發表於 2018-7-15 20:28 | 只看該作者

回復 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