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

帖子: 200
主題: 22
精華: 0
積分: 234
點名: 200
作業系統: Vista
軟體版本: Office2003
閱讀權限: 20
性別: 男
來自: 高雄
註冊時間: 2020-4-14
最後登錄: 2026-11-1

2025年全勤獎章 2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章論壇榮譽勳章論壇贊助勳章

26^#

發表於 2021-5-19 01:21 | 只看該作者

本帖最後由 BV7BW 於 2021-5-19 01:23 編輯

回復 24# jcchiang
J大大你好
上次關鍵字是否可在所查詢字欄中點其中1欄後.滑鼠指標可自動尋找到同一工作表相同字欄位上?
是否可行?

關鍵字vba.zip (118.14 KB)
項目對項目
客戶名稱對客戶名稱

關鍵字vba.zip (118.14 KB)

敏而好學,不恥下問

帖子: 200
主題: 22
精華: 0
積分: 234
點名: 200
作業系統: Vista
軟體版本: Office2003
閱讀權限: 20
性別: 男
來自: 高雄
註冊時間: 2020-4-14
最後登錄: 2026-11-1

2025年全勤獎章 2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章論壇榮譽勳章論壇贊助勳章

25^#

發表於 2021-3-31 16:57 | 只看該作者

回復 24# jcchiang
謝謝 J 大大
更改好 .用起來比較順
謝謝你指導謝謝

敏而好學,不恥下問

jcchiang

帖子: 234
主題: 19
精華: 0
積分: 276
點名: 0
作業系統: Windows XP
軟體版本: office 2003
閱讀權限: 20
性別: 男
註冊時間: 2013-1-7
最後登錄: 2021-10-7

24^#

發表於 2021-3-31 08:26 | 只看該作者

回復 23# BV7BW

可以多加一個判斷,當C有資料才去執行資料寫入
If Not c Is Nothing Then c.Copy Sheets("工作表2").[B4].Resize(, 3)

帖子: 200
主題: 22
精華: 0
積分: 234
點名: 200
作業系統: Vista
軟體版本: Office2003
閱讀權限: 20
性別: 男
來自: 高雄
註冊時間: 2020-4-14
最後登錄: 2026-11-1

2025年全勤獎章 2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章論壇榮譽勳章論壇贊助勳章

23^#

發表於 2021-3-30 18:33 | 只看該作者

回復 21# jcchiang
J大大你好
經測試後結果完全可運作
再轉至實際工作表中一樣很順暢
有遇到1問題後來才知道原因
在c.Copy Sheets("工作表2").[B4].Resize(, 3)
是未填入資料所以會出現錯誤
現在知道用法.多增學會運用技巧

再次謝謝 J 大大指導謝謝你

敏而好學,不恥下問

帖子: 200
主題: 22
精華: 0
積分: 234
點名: 200
作業系統: Vista
軟體版本: Office2003
閱讀權限: 20
性別: 男
來自: 高雄
註冊時間: 2020-4-14
最後登錄: 2026-11-1

2025年全勤獎章 2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章論壇榮譽勳章論壇贊助勳章

22^#

發表於 2021-3-30 12:40 | 只看該作者

回復 21# jcchiang
謝謝 J 大大
我在測試一下再向你報告
謝謝你

敏而好學,不恥下問

jcchiang

帖子: 234
主題: 19
精華: 0
積分: 276
點名: 0
作業系統: Windows XP
軟體版本: office 2003
閱讀權限: 20
性別: 男
註冊時間: 2013-1-7
最後登錄: 2021-10-7

21^#

發表於 2021-3-30 08:45 | 只看該作者

回復 20# BV7BW
1.關鍵字查詢並沒有提到編號只會輸入"A",所以項編是以全相符比對
請將If a = X Or a.Offset(, 1) Like "*" & X & "*" Or a.Offset(, 2) = X Then
改為 If Join(Application.Transpose(Application.Transpose(a.Resize(, 3))), "") Like "*" & X & "*" Then '把Sheets(3) D~F欄字串合併做模糊比對
2.Sheets("工作表2").Range([b4], [b4].End(4).Resize(, 3)).ClearContents '清除資料
是依所提供的資料去寫的,如果實際工作表有不一樣請自行修改
3.工作表3中"A""B""C"欄是原提供資料就有的,程式中並無使用

帖子: 200
主題: 22
精華: 0
積分: 234
點名: 200
作業系統: Vista
軟體版本: Office2003
閱讀權限: 20
性別: 男
來自: 高雄
註冊時間: 2020-4-14
最後登錄: 2026-11-1

2025年全勤獎章 2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章論壇榮譽勳章論壇贊助勳章

20^#

發表於 2021-3-29 16:27 | 只看該作者

回復 19# BV7BW
J大大你好
第2版本經測試後
1)可正常運作所需查詢動作
有1點是無法再用"B"欄查詢
可說用A101就可查詢.如用A就不可行.出現錯誤*c.Copy Sheets("工作表2").[b4].Resize(, 3)*
在"C"."D"欄中就可以.如"D"欄輸入"高"就可查詢運作
2)當我轉換至實際使用工作表時
會出現錯誤*Sheets("工作表2").Range([b4], [b4].End(4).Resize(, 3)).ClearContents*
往下就無法再測試
再請問工作表3中"A""B""C"欄在程式中有用途.或是有需要?
在這裡先向J大大說非常感謝
讓我再多一層深入
可請J大大再幫程式注解
非常謝謝你
附上測試檔

關鍵字vba修改 - 複製.zip (130.91 KB)

敏而好學,不恥下問

帖子: 200
主題: 22
精華: 0
積分: 234
點名: 200
作業系統: Vista
軟體版本: Office2003
閱讀權限: 20
性別: 男
來自: 高雄
註冊時間: 2020-4-14
最後登錄: 2026-11-1

2025年全勤獎章 2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章論壇榮譽勳章論壇贊助勳章

19^#

發表於 2021-3-29 09:23 | 只看該作者

回復 17# jcchiang
謝謝J大大回應謝謝
現我再測試一下
第一版本是按下後整畫面沒有回應=當機
現我再以第2版本測試
再向你報告測試結果
再次謝謝你 J大大謝謝

敏而好學,不恥下問

帖子: 200
主題: 22
精華: 0
積分: 234
點名: 200
作業系統: Vista
軟體版本: Office2003
閱讀權限: 20
性別: 男
來自: 高雄
註冊時間: 2020-4-14
最後登錄: 2026-11-1

2025年全勤獎章 2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章論壇榮譽勳章論壇贊助勳章

18^#

發表於 2021-3-29 09:12 | 只看該作者

回復 16# samwang
感謝 S 大大先進勞心指導謝謝你
現整組程式已完全可理解也可正常運作
先前不能保護動作.以加上鎖定即解除動作.如下
Sub tt1()
Worksheets("工作表2").Unprotect ("0123") '保護工作表2
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
Sheets("工作表2").Protect ("0123") '取消保護工作表2
End Sub

敏而好學,不恥下問