Sub查找單價()
  Dim var As Variant, iRow As Integer
  iRow=3
  Do Until IsEmpty(Cells(iRow, 1))
      var=Application.Match(Cells(iRow, 2), Sheets("單價表").Columns(1), 0)
      If Not IsError(var) Then
        Cells(iRow, 4).Value=Sheets("單價表").Cells(var, 2).Value
      End If
      iRow=iRow+1
  Loop
End Sub

Sub成績搜索()
Dim t, arr(), intRows As Integer
    t=Timer  '初始化時間變量
    Application.ScreenUpdating=False
    On Error Resume Next
    Range("c2:h1048576").Clear  '清除上次查詢信息
    查找值=Cells(2, 1)       '設(shè)定查找目標為A2的值
    For i=2 To Sheets.Count   '遍歷工作表（第一個表即當前表除外）
      Set c=Sheets(i).Range("a2:a100").Find(what:=查找值)
                      'A2∶A100可以是自己根據(jù)實際狀況定義區(qū)域大小
      If Not c Is Nothing Then
          firstAddress=c.Address
          Do
              intRows=intRows+1 '累加計數(shù)器
              ReDim Preserve arr(1 To 6, 1 To intRows)  '重定義數(shù)組變量
              arr(1, intRows)=Sheets(i).Name
                              '數(shù)組第一子項目賦值為查找到的數(shù)據(jù)所在工作表名
              arr(2, intRows)=c.Address
                              '數(shù)組第二子項目賦值為查找到的數(shù)據(jù)所在單元格地址
              arr(3, intRows)=c.Value
                          '數(shù)組第三子項目賦值為查找到的數(shù)據(jù)
            arr(4, intRows)=c.Offset(0, 1).Text
                        '數(shù)組第四子項目賦值為查找到的數(shù)據(jù)右移一個單元格的值
            arr(5, intRows)=c.Offset(0, 2).Text
                        '數(shù)組第五子項目賦值為查找到的數(shù)據(jù)右移二個單元格的值
            arr(6, intRows)=c.Offset(0, 3).Text
                        '數(shù)組第六子項目賦值為查找到的數(shù)據(jù)右移三個單元格的值
            Set c=Sheets(i).Range("a2:a100").FindNext(c)
          Loop While Not c Is Nothing And c.Address <> firstAddress
      End If
  Next
  Range("C2:h" & intRows)=Application.Transpose(arr)
                              '將找到的值賦予單元格區(qū)域
  Range("C2:h" & intRows).Borders.LineStyle=xlContinuous  '添加邊框
  Application.ScreenUpdating=True
  MsgBox Format(Timer-t, "0.00") & "秒"  '提示總運行時間
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Address="$B$1" Then
      Dim cn As Object, Sql$, sh As Worksheet
      Set cn=CreateObject("ADODB.Connection")
      cn.Open "provider=microsoft.jet.oledb.4.0;extended properties=
      'excel 8.0;imex=1';data source=" & ThisWorkbook.FullName
      Application.ScreenUpdating=False
      Range("A4:d" & [A1048576].End(xlUp).Row+1).Clear
      For Each sh In Worksheets
          If sh.Name <> "電話查詢" Then
              Sql="select * from [" & sh.Name & "$] where姓名like '%"
              & [b1].Text & "%'"
              [A65536].End(xlUp).Offset(1,0).CopyFromRecordset cn.Execute(Sql)
          End If
      Next sh
      Application.ScreenUpdating=True
      cn.Close
      Range("A4:d" & [A1048576].End(xlUp).Row).Borders.LineStyle=
      xlContinuous'線型
      Set cn=Nothing
    End If
End Sub

Sub工號查詢()
  Application.ScreenUpdating=False
  Dim i, cell As Range
  For i=1 To Range("a1048576").End(xlUp).Row-1
  For Each cell In Range("A2:A" & Range("a1048576").End(xlUp).Row)
  cell.Offset(0, 1)=Sheets("人事資料").Range("B" & WorksheetFunction.
      Match(cell, Sheets("人事資料").Range("a1:a21"), 0))
  Next cell
Next i
Application.ScreenUpdating=True
End Sub

Sub替換()
  ActiveSheet.UsedRange.Replace What:="PC",Replacement:="電腦",LookAt:=xlPart
End Sub

Sub多表替換()
    Dim sh_count As Byte, row_count As Long  '聲明變量
    For sh_count=1 To Sheets.Count      '為變量賦值，范圍是1到工作表數(shù)量
    For row_count=2 To Sheets(sh_count).Range("a1048576").End(xlUp).Row
      '為變量賦值
     If Sheets(sh_count).Cells(row_count, 2) >=60 Then  '如果成績大于等于60
     Sheets(sh_count).Cells(row_count, 2)="合格"    '替換為“合格”
    End If
    Next row_count                                   '重復下一行
    Next sh_count                                   '重復下一個工作表
End Sub