|
本帖最后由 feiaoli 于 2017-1-20 22:52 编辑
- Sub test()
- Dim r%, i%
- Dim arr, brr()
- Dim d As Object
- Set d = CreateObject("scripting.dictionary")
- With Worksheets("科目汇总")
- r = .Cells(.Rows.Count, 2).End(xlUp).Row
- arr = .Range("b6:ab" & r)
- End With
- ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
- m = 0
- For i = 1 To UBound(arr)
- If arr(i, 5) = 1 And arr(i, 18) + arr(i, 19) <> 0 Then
- m = m + 1
- For j = 1 To UBound(arr, 2)
- brr(m, j) = arr(i, j)
- Next
- End If
- Next
- With Worksheets("提取数据表格")
- .UsedRange.Offset(5, 0).ClearContents
- .Range("b6").Resize(UBound(brr), UBound(brr, 2)) = brr
- End With
- End Sub
复制代码 求助:把以上一位老师的代码放在("提取数据表格")表格下,达到打开此表("提取数据表格")或者数据源表("科目汇总")输入数据本表("提取数据表格")自动刷新!谢谢!
已解决。
- Private Sub Worksheet_Activate()
- Dim r%, i%
- Dim arr, brr()
- Dim d As Object
- Set d = CreateObject("scripting.dictionary")
- With Worksheets("科目汇总")
- r = .Cells(.Rows.Count, 2).End(xlUp).Row
- arr = .Range("b6:ab" & r)
- End With
- ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
- m = 0
- For i = 1 To UBound(arr)
- If arr(i, 5) = 1 And arr(i, 18) + arr(i, 19) <> 0 Then
- m = m + 1
- For j = 1 To UBound(arr, 2)
- brr(m, j) = arr(i, j)
- Next
- End If
- Next
- With Worksheets("提取数据表格")
- .UsedRange.Offset(5, 0).ClearContents
- .Range("b6").Resize(UBound(brr), UBound(brr, 2)) = brr
- End With
- End Sub
复制代码
|
|