目的:根据用户选择复制满足一定条件的Excel行到另外一个行中。
注意红色的关键代码。
'把包含某一个数字的记录,
'全部复制到result 工作簿里
'用户选择的range范围
Sub findByNumber()
Dim rng As Range
Dim newrng As Range
Dim Tools As New Toolkit
Dim choice As Integer
Dim cell As Object
Dim rRow As Range
Dim inyes As Boolean
Dim realnumber As Integer
Dim name As String
Dim counter As Integer
inyes = False
On Error Resume Next
counter = 1
choice = Application.InputBox("输入包含的数字", "查找的数字", Type:=1)'必须为数字
Set rng = Application.InputBox("选择数据范围", "选择数据", Selection.Address, , , , , 8)
If rng Is Nothing Then
MsgBox "你没有选择数据,不能继续"
Exit Sub
End If
name = rng.Parent.name
Add_Sheet ("result")
realnumber = choice
Sheets(name).Activate
If realnumber = 0 Then
Else
On Error GoTo errorhandler
For Each rRow In rng.Rows
inyes = False
For Each cell In rRow.Cells
If cell.value = realnumber Then '行中某一列的值同用户输入的值相等，则该行复制到result
inyes = True
rRow.Copy
Sheets("result").Activate
Sheets("result").Cells(counter, 1).Select
Sheets("result").Paste
counter = counter + 1
Sheets(name).Activate
Exit For
End If
Next 'for
Next
End If
Sheets("result").Activate
Exit Sub
errorhandler:
MsgBox Err.Description & Err.Source
End Sub
