- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
10#
發表於 2014-5-7 17:00
| 只看該作者
回復 9# jackson7015
試試看- '都是Module3上的程式碼
- Sub 查詢資料()
- ' Worksheet_Change [A5] '可以這樣做
- Ex
- End Sub
- 'Sheets("查詢用表單")的Worksheet_Change事件,你是想搬移到Module3模組上
- Private Sub Worksheet_Change(ByVal Target As Range)
- Dim A As Range, Rng As Range
- If Target.Column = 1 Then
- With Sheets("綜合資料庫")
- For i = 1 To .UsedRange.Rows.Count
- Set A = .UsedRange.Rows(i).Find(Target)
- If Not A Is Nothing Then
- If Rng Is Nothing Then
- Set Rng = .UsedRange.Rows(i)
- Else
- Set Rng = Union(Rng, .UsedRange.Rows(i))
- End If
- End If
- Next
- End With
- End If
- Application.EnableEvents = False
- If Not Rng Is Nothing Then
- Rng.Copy: Target.Offset(, 1).PasteSpecial 3
- Else
- Target.Offset(, 1).Resize(, 50) = ""
- End If
- Application.EnableEvents = True
- MsgBox "查詢結束"
- End Sub
- Private Sub Ex()
- Dim F As Range, AD As String, Rng As Range, xRng As Range
- Set xRng = Sheets("查詢用表單").[A5]
- With Sheets("綜合資料庫").UsedRange
- Set F = .Find(xRng, LOOKAT:=xlPart)
- If Not F Is Nothing Then AD = F.Address
- Do While Not F Is Nothing
- If Rng Is Nothing Then
- Set Rng = .Rows(F.Row)
- Else
- Set Rng = Union(Rng, .Rows(F.Row))
- End If
- Set F = .FindNext(F)
- If F.Address = AD Then Exit Do
- Loop
- End With
- If Not Rng Is Nothing Then
- Rng.Copy xRng.Offset(, 1)
- MsgBox "查詢結束"
- Else
- xRng.Offset(, 1).Resize(, 50) = ""
- End If
- End Sub
複製代碼 |
|