|
- Sub test()
- On Error GoTo ErrorHandler
-
- Dim arr, arrResult()
- Dim i As Long, j As Long, Match, k As Long
-
- '检测H1单元格有要查找的内容
- If Len(Range("h1").Value) = 0 Then
- MsgBox "H1单元格没有要匹配的值"
- Exit Sub
- End If
-
- '读入单元格数据到数组,并调整结果数组大小
- arr = Range("a1").CurrentRegion
- ReDim arrResult(1 To UBound(arr), 1 To UBound(arr, 2))
-
- '匹配值
- Match = [h1].Value
-
- '数组第一维循环
- For i = LBound(arr) To UBound(arr)
- '检测第4列值是否匹配
- If arr(i, 4) = Match Then
- '符合条件的数量加1
- k = k + 1
- '把符合条件的整行数据循环写入结果数组
- For j = LBound(arr, 2) To UBound(arr, 2)
- arrResult(k, j) = arr(i, j)
- Next
- End If
- Next
- '关属性
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Application.EnableEvents = False
- Application.Calculation = xlCalculationManual
-
- '数组数组写回单元格,列宽自适应
- With Range("l1")
- If Len(.Value) Then .CurrentRegion.ClearContents
- .Resize(k, UBound(arr, 2)).Value = arrResult
- .CurrentRegion.EntireColumn.AutoFit
- End With
-
- '开属性
- Application.ScreenUpdating = True
- Application.DisplayAlerts = True
- Application.EnableEvents = True
- Application.Calculation = xlCalculationAutomatic
-
- '对话框提示完成
- MsgBox "提取完成"
- Exit Sub
-
- ErrorHandler:
- MsgBox Err.Number & vbCrLf & _
- Err.Description
- End Sub
复制代码 |
|