[已解决]在B表通过下拉菜单选择一个数据，然后把A表中满足的记录复制过来

月黑杀人 · 发表于 2015-5-15 15:28

1.在报表中，《使用单位》通过下拉菜单选择一个数据，然后把A表中满足的记录复制过来。
2.根据不同车号，计算行驶里程和时间

最佳答案

Excel学徒123

2015-5-15 15:29

Sub test()
Dim arr, brr, crr()
Dim d As Object
Dim Icolumn%, Irow%, Iar%, Ibr%, k%, icr%
Dim str As String
Range("a5:O65500").ClearContents
str = Application.InputBox("请输入您要查询的部门名称", "提示", , , , , , 2)
If str = "" Then Exit Sub
Range("B3") = str
[N3] = Date
With Worksheets("使用信息")
Icolumn = .Range("1:1").Find("用车部门", , , , xlWhole).Column
Irow = .Cells(Rows.Count, 1).End(3).Row
arr = .Range("a1").CurrentRegion
ReDim crr(1 To UBound(arr), 1 To Application.WorksheetFunction.CountA(Range("4:4")))
For Iar = 1 To UBound(arr)
If arr(Iar, Icolumn) = str Then
k = k + 1
For icr = 1 To UBound(crr, 2)
crr(k, icr) = arr(Iar, icr)
Next
End If
Next
End With
On Error GoTo star
[A5].Resize(k, UBound(crr, 2)) = crr
star:
End Sub

复制代码

Excel学徒123 · 发表于 2015-5-15 15:29

Sub test()
Dim arr, brr, crr()
Dim d As Object
Dim Icolumn%, Irow%, Iar%, Ibr%, k%, icr%
Dim str As String
Range("a5:O65500").ClearContents
str = Application.InputBox("请输入您要查询的部门名称", "提示", , , , , , 2)
If str = "" Then Exit Sub
Range("B3") = str
[N3] = Date
With Worksheets("使用信息")
Icolumn = .Range("1:1").Find("用车部门", , , , xlWhole).Column
Irow = .Cells(Rows.Count, 1).End(3).Row
arr = .Range("a1").CurrentRegion
ReDim crr(1 To UBound(arr), 1 To Application.WorksheetFunction.CountA(Range("4:4")))
For Iar = 1 To UBound(arr)
If arr(Iar, Icolumn) = str Then
k = k + 1
For icr = 1 To UBound(crr, 2)
crr(k, icr) = arr(Iar, icr)
Next
End If
Next
End With
On Error GoTo star
[A5].Resize(k, UBound(crr, 2)) = crr
star:
End Sub

复制代码

月黑杀人 · 发表于 2015-5-15 15:35

Excel学徒123 发表于 2015-5-15 15:29

非常感谢！

		自动登录	找回密码
密码			注册