返回列表 上一主題 發帖

[發問] VBA 搜尋的問題

本帖最後由 yen956 於 2015-11-6 17:52 編輯

試試看:
Q1:
  1. Private Sub CommandButton1_Click()
  2.     Dim sCel As Range
  3.     Dim inTxt, First1 As String
  4.     Dim LastRow As Long
  5.     Range("K2:N" & Rows.Count & "").ClearContents    '清除先前搜尋的資料"
  6.     inTxt = InputBox("請輸入搜尋班級", "搜尋班級")
  7.     If inTxt = "" Then Exit Sub                      '若使用者按 [取消] 則離開
  8.     Set sCel = [A:A].Find(What:=inTxt, LookAt:=xlWhole)
  9.     If sCel Is Nothing Then
  10.         MsgBox ("未找到你要搜尋的班級"), vbCritical
  11.         Exit Sub
  12.     End If
  13.     First1 = sCel.Address                       '保留第一個搜尋到的位址
  14.     Do
  15.         LastRow = Cells(Rows.Count, 11).End(xlUp).Row + 1
  16.         sCel.Resize(1, 4).Copy Cells(LastRow, 11)
  17.         Set sCel = [A:A].FindNext(sCel)        '尋找下一個
  18.     Loop Until First1 = sCel.Address            '下一個的位置=第一個的位置(回到第一個的位置)
  19. End Sub
複製代碼
Q2:
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     Dim sh1, sh2 As Object
  3.     Dim sCel As Range
  4.     Dim First1 As String
  5.     Dim LastRow As Long
  6.     Set sh1 = Sheets("工作表1")
  7.     Set sh2 = Sheets("工作表2")
  8.     If Intersect(Target, sh2.[I1]) Is Nothing Then Exit Sub
  9.     If Target = "" Then Exit Sub
  10.     sh2.Range("H4:K" & sh2.Rows.Count & "").ClearContents    '清除先前搜尋的資料"
  11.     sh1.Activate
  12.     With sh1
  13.         Set sCel = .[A:B].Find(What:=Target, LookAt:=xlPart)
  14.         If sCel Is Nothing Then
  15.             MsgBox ("未找到你要搜尋的資料"), vbCritical
  16.             Exit Sub
  17.         End If
  18.         First1 = sCel.Address                          '保留第一個搜尋到的位址
  19.         Do
  20.             LastRow = sh2.Cells(sh2.Rows.Count, 8).End(xlUp).Row + 1
  21.             sCel.Resize(1, 4).Copy sh2.Cells(LastRow, 8)
  22.             Set sCel = .[A:B].FindNext(sCel)           '尋找下一個
  23.         Loop Until First1 = sCel.Address               '下一個的位置=第一個的位置(回到第一個的位置)
  24.     End With
  25.     sh2.Activate
  26. End Sub
複製代碼

TOP

        靜思自在 : 君子如水,隨方就圓,無處不自在。
返回列表 上一主題