關鍵字查詢可改為VBA方式按鈕查詢 - Excel程式區

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2026-5-26

1^# 跳轉到 »

發表於 2021-3-25 11:49 | 顯示全部帖子

回復 1# BV7BW

請測試看看，謝謝。
Sub tt()
Dim Arr, xD, i&, N%, T
Set xD = CreateObject("Scripting.Dictionary")
Sheets("工作表2").Range("b4:d200") = ""
Arr = Range([工作表3!F1], [工作表3!D65536].End(3))
For i = 2 To UBound(Arr)
T = Int(Replace(Arr(i, 1), "A", "") - 100)
xD(T & "") = Array(Arr(i, 1), Arr(i, 2), Arr(i, 3))
Next
Arr = Range([工作表2!D3], [工作表2!A65536].End(3))
For i = 2 To UBound(Arr)
If xD.Exists(Arr(i, 1) & "") Then
      Arr(i, 2) = xD(Arr(i, 1) & "")(0)
      Arr(i, 3) = xD(Arr(i, 1) & "")(1)
      Arr(i, 4) = xD(Arr(i, 1) & "")(2)
      N = N + 1
End If
Next
If N > 0 Then Sheets("工作表2").[A3].Resize(N, 4) = Arr
End Sub

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2026-5-26

2^#

發表於 2021-3-28 18:09 | 顯示全部帖子

回復 8# BV7BW

請再測試看看，感謝。
Sub tt1()
Dim Arr, i&, N%, T, pos%, pos2%, pos3%
Sheets("工作表2").Range("A4:D1000") = ""
T = [工作表2!C2]
Arr = Range([工作表3!G1], [工作表3!D65536].End(3))
For i = 2 To UBound(Arr)
pos = InStr(Arr(i, 1), T): pos2 = InStr(Arr(i, 2), T)
pos3 = InStr(Arr(i, 3), T)
If pos > 0 Or pos2 > 0 Or pos3 > 0 Then
      N = N + 1: Arr(N, 1) = Format(N, "00")
      For j = 2 To 4: Arr(N, j) = Arr(i, j - 1): Next
End If
Next
If N > 0 Then
With Sheets("工作表2")
      .Range(.[A4], .Cells(N + 3, 1)).NumberFormatLocal = "@"
      .[A4].Resize(N, 4) = Arr
End With
End If
End Sub

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2026-5-26

3^#

發表於 2021-3-29 07:39 | 顯示全部帖子

回復 samwang
S大大你好
回原操作工作表中.經測試後以可完全運作
有個問題是無法作保護工作表
卡在. ...
BV7BW 發表於 2021-3-28 23:01

執行前可以先解開保護，執行完畢後可再加入保護，謝謝

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2026-5-26

4^#

發表於 2021-3-29 07:43 | 顯示全部帖子

回復 13# BV7BW

那段的意思是將工作表2的A欄有資料的序號改為文字格式，謝謝。

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2026-5-26

5^#

發表於 2021-3-29 07:55 | 顯示全部帖子

回復 13# BV7BW

Sub tt1()
Dim Arr, i&, N%, T, pos%, pos2%, pos3%
Sheets("工作表2").Range("A4:D1000") = "" '清除工作表2的資料
T = [工作表2!C2] '查找字
Arr = Range([工作表3!G1], [工作表3!D65536].End(3)) '將工作表3資料D~G欄位資料放在數組中
For i = 2 To UBound(Arr)
   pos = InStr(Arr(i, 1), T): pos2 = InStr(Arr(i, 2), T)
   pos3 = InStr(Arr(i, 3), T)       '查詢字確認有無在工作表3的D、E、F欄
   If pos > 0 Or pos2 > 0 Or pos3 > 0 Then  '有找到時
      N = N + 1: Arr(N, 1) = Format(N, "00")    '有資料時Arr的第1欄位，自動產生序號
      For j = 2 To 4: Arr(N, j) = Arr(i, j - 1): Next '將工作表3資料D、E、F欄資料暫時存放在Arr
   End If
Next
If N > 0 Then '確認有無找到資料
   With Sheets("工作表2")
      .Range(.[A4], .Cells(N + 3, 1)).NumberFormatLocal = "@" 'A欄改為文字格式
      .[A4].Resize(N, 4) = Arr '有找到資料救回填至工作表2
   End With
End If
End Sub

TOP

samwang