[已解决]VBA按日期提取数据

sd3000sd3000 · 发表于 2013-3-8 13:13

按日期要求将分表中的数据提取到总表的对应月份。谢谢了。

VBA数据提取.rar (24.49 KB, 下载次数: 73)

sd3000sd3000 · 发表于 2013-3-8 18:55

下标=上界-下界+1 是不是A列中有合并单元格的原因？哪位高手看一下。

hwc2ycy · 发表于 2013-3-9 12:29

==，帮你看看。其实也不难的。

hwc2ycy · 发表于 2013-3-9 12:42

表做得极不合理。
明细表中的日期明明是某一天的日期的，你给整来个按月显示。

hwc2ycy · 发表于 2013-3-9 13:14

代码放在汇总工作表模块内

Sub 汇总数据()
If Len([a3]) = 0 Then MsgBox "A3单元格输入要查询的年份", vbCritical + vbOKOnly: Exit Sub
On Error Resume Next
If Not IsDate(DateSerial([a3], 1, 1)) Then MsgBox "A3单元格输入要查询的年份", vbCritical + vbOKOnly: Exit Sub
On Error GoTo 0
Dim cYear As String
cYear = [a3] & "年"
Dim arr, arrb()
Dim iLastRow As Byte
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row - 1
arr = Range("a4:e" & iLastRow)
ReDim arrb(1 To UBound(arr))
Dim i As Byte
Dim rg As Range
Dim arrEmpty(1 To 4)
Application.ScreenUpdating = False
With Worksheets("明细")
On Error Resume Next
For i = LBound(arr) To UBound(arr)
Set rg = .Range("a:a").Find(what:=cYear & arr(i, 1), LookIn:=xlValues, lookat:=xlWhole)
If Not rg Is Nothing Then
arrb(i) = rg.Offset(, 1).Offset(2, 1).Resize(, 4).Value
Else
arrb(i) = arrEmpty
End If
Set rg = Nothing
Next
End With
arrb = WorksheetFunction.Transpose(WorksheetFunction.Transpose(arrb))
Range("b4").Resize(UBound(arrb), UBound(arrb, 2)) = arrb
Application.ScreenUpdating = True
MsgBox "汇总完成", vbInformation + vbOKOnly
End Sub

复制代码

sd3000sd3000 · 发表于 2013-3-9 16:09

hwc2ycy 发表于 2013-3-9 12:42
表做得极不合理。
明细表中的日期明明是某一天的日期的，你给整来个按月显示。

因为日期是随便输入的，而数据是这个月的，所以把它来了个按月显示。谢谢班长，代码很好。

hwc2ycy · 发表于 2013-3-9 16:27

既然好了，那就给个最佳，

sd3000sd3000 · 发表于 2013-3-9 22:36

班长：对不起，最佳是您的5楼，点错了，希望版主调整一下。谢谢班长。

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