VBA 資料搜尋問題

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2805
主題: 10
精華: 0
積分: 2861
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-5-4

1^# 跳轉到 »

發表於 2018-9-13 11:52 | 顯示全部帖子

以〔雙按滑鼠左鍵〕執行，可〔單條件〕或〔多條件〕搜尋：

多條件搜尋01.rar (21.2 KB)

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2805
主題: 10
精華: 0
積分: 2861
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-5-4

2^#

發表於 2018-9-14 09:39 | 顯示全部帖子

回復 30# Qin

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
With Target
   If .Address = "$C$1" Then
      Cancel = True
      If [B1] = "" Then MsgBox "未輸入搜尋文字！ ", 0 + 16: Exit Sub
      Call 搜尋(Array([B1], "", ""), Array(6, 7, 4))
      .Interior.ColorIndex = 6: [B1].Interior.ColorIndex = 6
   ElseIf .Address = "$C$2" Then
      Cancel = True
      If [B2] = "" Then MsgBox "未輸入搜尋文字！ ", 0 + 16: Exit Sub
      Call 搜尋(Array("", [B2], ""), Array(6, 7, 4))
      .Interior.ColorIndex = 6: [B2].Interior.ColorIndex = 6
   ElseIf .Address = "$C$3" Then
      Cancel = True
      If [B3] = "" Then MsgBox "未輸入搜尋文字！ ", 0 + 16: Exit Sub
      Call 搜尋(Array("", "", [B3]), Array(6, 7, 4))
      .Interior.ColorIndex = 6: [B3].Interior.ColorIndex = 6
   ElseIf .Address = "$A$1:$A$3" Then
      Cancel = True
      If [B1] & [B2] & [B3] = "" Then MsgBox "未輸入搜尋文字！ ", 0 + 16: Exit Sub
      Call 搜尋(Array([B1], [B2], [B3]), Array(6, 7, 4))
      .Interior.ColorIndex = 6: [B1:B3].Interior.ColorIndex = 6
   End If
End With
End Sub

'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Sub 搜尋(Ur1, Ur2)
Dim Sht As Worksheet, xU As Range, xE As Range, k%
Call 清除
For Each Sht In Sheets
If Left(Sht.Name, 4) <> "Data" Then GoTo 101
If Sht.FilterMode Then Sht.ShowAllData
Set xU = Sht.UsedRange
For k = 0 To 2
      If Ur1(k) <> "" Then
         xU.AutoFilter Field:=Ur2(k), Criteria1:=Ur1(k)
      End If
Next k
Set xE = Cells(Rows.Count, 1).End(xlUp)(2)
If xE.Row < 6 Then Set xE = [A6]
xU.Offset(1, 0).Copy xE
Sht.AutoFilterMode = False
101: Next
Set xE = Cells(Rows.Count, 1).End(xlUp)
If xE.Row < 6 Then MsgBox "找不到符合的資料！ ": Exit Sub
[A6:J6].Interior.ColorIndex = 35
[A7:J7].Interior.ColorIndex = 6
[A6:J7].Copy
Range(xE, [J6]).PasteSpecial Paste:=xlFormats
xE(2).EntireRow.Delete
[A6].Select
End Sub

Sub 清除()
With Sheets("Search")
   If .FilterMode Then .ShowAllData
   With .UsedRange.Offset(5, 0)
      .ClearContents
      .Interior.ColorIndex = xlNone
   End With
   .[A1,C1:C3].Interior.ColorIndex = 15
   .[B1:B3].Interior.ColorIndex = 35
   .[A6].Select
End With
End Sub
　
　

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2805
主題: 10
精華: 0
積分: 2861
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-5-4

3^#

發表於 2018-9-14 10:08 | 顯示全部帖子

改一下[雙擊觸發]部份:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim T1$, T2$, T3$, R As Range, C%
With Target
   Select Case .Item(1).Address(0, 0)
   Case "C1": T1 = [B1]: Set R = [B1]: C = 1
   Case "C2": T2 = [B2]: Set R = [B2]: C = 1
   Case "C3": T3 = [B3]: Set R = [B3]: C = 1
   Case "A1": T1 = [B1]: T2 = [B2]: T3 = [B3]: Set R = [B1:B3]: C = 1
End Select
If C = 0 Then Exit Sub
Cancel = True
If T1 & T2 & T3 = "" Then MsgBox "未輸入搜尋文字！ ", 0 + 16: Exit Sub
Call 搜尋(Array(T1, T2, T3), Array(6, 7, 4))
Union(.Cells, R).Interior.ColorIndex = 6
End With
End Sub

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2805
主題: 10
精華: 0
積分: 2861
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-5-4

4^#

發表於 2018-9-14 14:21 | 顯示全部帖子

回復 36# Qin

SearchData01.rar (48.77 KB)

只能用2003版檔案格式, ".xls" 須改為 2007版以上的副檔名
〔檔案路徑〕自行去修改

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2805
主題: 10
精華: 0
積分: 2861
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-5-4

5^#

發表於 2018-9-16 09:48 | 顯示全部帖子

回復 38# Qin

1) Data 檔資料持續增加中, 在有新資料更新才會打開更新 (有用密碼鎖上的 " 1234") , 所以希望在使用 Search Data檔搜尋資料時, Data 檔是不需要打開的
　＿data是以〔唯讀〕開啟的，並不影響原檔自己的資料
2) 希望搜尋結果所呈現的 "Date" 是由現今的年份至較久遠的年份...
　＿什麼意思？？？
3) 臨時想起, 想增加1個"日期"搜尋功能, 請参考 Search Data檔
　＿如果日期都不輸入，如何篩？
　＿三條件不輸入，只有日期，如何篩？

TOP

准提部林