小福利,用Excel VBA设计一个查询小应用
Option Explicit
Sub 查询_Click()
Dim rng1, rng2, rng As Range
Dim firstaddress
Dim a As Integer
a = 4
Sheets("查询").Range(Cells(4, "b"), Cells(Sheets("查询").UsedRange.Rows.Count, "e")).Delete
With Sheets("交底书").Range("A:D")
Set rng1 = .Find(Sheets("查询").Cells(2, 2).Text, lookat:=xlPart)
If Not rng1 Is Nothing Then
firstaddress = rng1.Address
Do
If InStr(rng1, Sheets("查询").Cells(2, 3)) > 0 And InStr(rng1, Sheets("查询").Cells(2, 4)) > 0 Then
Range("B" & a) = "=交底书!$A$" & Right(rng1.Address, Len(rng1.Address) - 3)
Range("C" & a) = "=交底书!$B$" & Right(rng1.Address, Len(rng1.Address) - 3)
Range("D" & a) = "=交底书!$C$" & Right(rng1.Address, Len(rng1.Address) - 3)
Range("E" & a) = "=交底书!$D$" & Right(rng1.Address, Len(rng1.Address) - 3)
Range("D" & a).Hyperlinks.Add Anchor:=Range("D" & a), Address:="", SubAddress:= _
"交底书!C" & Right(rng1.Address, Len(rng1.Address) - 3)
Range("E" & a).Hyperlinks.Add Anchor:=Range("E" & a), Address:="", SubAddress:= _
"交底书!D" & Right(rng1.Address, Len(rng1.Address) - 3)
a = a + 1
End If
Set rng1 = .FindNext(rng1)
If rng1 Is Nothing Then
GoTo DoneFinding
End If
Loop While rng1.Address <> firstaddress
End If
DoneFinding:
End With
MsgBox ("共查出" & (Sheets("查询").UsedRange.Rows.Count - 3) & "条记录")
End Sub
Sub 清空_Click()
Sheets("查询").Range(Cells(4, "b"), Cells(Sheets("查询").UsedRange.Rows.Count, "e")).Delete
End Sub