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

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

17^# 跳轉到 »

發表於 2021-3-29 08:50 | 只看該作者

回復 7# BV7BW

原程式測試時並無當機問機,所以不了解你所說會當機是什麼問題
只是原程式不知道判斷條件是以Sheets("工作表2").[C2]為主
修改後程式如下
  Sub ex()
Dim X$, a As Variant, c As Variant
Set c = Nothing
Sheets("工作表2").Range([b4], [b4].End(4).Resize(, 3)).ClearContents
X = Sheets("工作表2").[C2]
For Each a In Sheets("工作表3").Range([工作表3!D2], [工作表3!D2].End(4))
If a = X Or a.Offset(, 1) Like "*" & X & "*" Or a.Offset(, 2) = X Then  '判斷是否有符合條件
   If c Is Nothing Then
      Set c = a.Resize(, 3)
   Else
      Set c = Union(c, a.Resize(, 3))
   End If
End If
Next
c.Copy Sheets("工作表2").[b4].Resize(, 3)
End Sub

TOP

samwang

大學生 Rank: 4

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

16^#

發表於 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

大學生 Rank: 4

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

15^#

發表於 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

14^#

發表於 2021-3-29 07:39 | 只看該作者

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

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

TOP

BV7BW

中學生 Rank: 2

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

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

13^#

發表於 2021-3-29 07:08 | 只看該作者

回復 10# samwang
S大大你好
我已成功利用這2組程式
Worksheets("工作表2").Unprotect ("0123")
Sheets("工作表2").Protect ("0123")
去做保護動作
但我很想知道程式註解尤其是這段
.Range(.[A4], .Cells(N + 3, 1)).NumberFormatLocal = "@"
我再理解會比較慢.如有你註解可加速融通
再次謝謝 s大指導謝謝

敏而好學,不恥下問

TOP

BV7BW

中學生 Rank: 2

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

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

12^#

發表於 2021-3-28 23:01 | 只看該作者

回復 10# samwang
S大大你好
回原操作工作表中.經測試後以可完全運作
有個問題是無法作保護工作表
卡在.Range(.[A4], .Cells(N + 3, 1)).NumberFormatLocal = "@"這裡
請S大在幫看看如何可用保護工作表操作
再請S大大可在程式後加注解
謝謝你

敏而好學,不恥下問

TOP

BV7BW

中學生 Rank: 2

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

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

11^#

發表於 2021-3-28 19:13 | 只看該作者

回復 10# samwang

謝謝s大
完全符合工作需求
我先理解一下
可有一些不懂地方想請s大大再幫注解
感謝s大謝謝

敏而好學,不恥下問

TOP

samwang

大學生 Rank: 4

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

10^#

發表於 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

BV7BW