使用VBA在Excel工作表中搜索日期，以便按月合并数据
使用VBA在Excel工作表中搜索日期，以便按月合并数据
提问于 2016-08-31 11:35:50
我的工作簿中有未知数量的工作表，但每个工作表共享相同的格式。每张工作表代表一个工作周。这几周可以跨越几个日历月。每列都有一行，它反映了一周中的某一天，并且有一个日期单元格。日期格式为dd/mm/yr
我的代码当前查找工作表的数量，并解析工作表以将特定信息合并到摘要工作表中。此信息采用年初至今(YTD)格式。
除了YTD格式，我需要能够拉出一个日历月的数据。
每个工作表具有最多5个单元格的数据(一周中的一天)和两组最多5个单元格(即工艺路线小时数和总小时数，最多5个条目-周一至周五，如果在活动月份内)单元格将被加在一起，产生两个总和。这需要在一个日历月的每个工作周完成，然后输出到我的汇总表的总值。
下面的代码是我用来浏览每个数据表并获取YTD数据的代码。我想添加代码来涵盖每月的数据提取，但我在实现这样的代码时遇到了极大的困难--我一直在思考。
Dim I As Integar
Dim WS_Count As Integar
Dim ConsolidationArrayYTDTotalDailyAve() 'Array storage YTD Tot Daily Ave
WS_Count = ActiveWorkbook.Worksheets.Count ' last worksheet
ReDim ConsolidationArrayYTDTotalDailyAve(WS_Count-2)
For I = 2 to WS_Count 'check from 2nd WS as first sheet is the summary
ConsolidationArrayYTDTotalDailyAve(I - 2) = Worksheets(I).Name & "!R54C3:R56C8" 'Grab the data from each sheet and save in the array
Next I
Sheets("Summary").Range("B4").Consolidate sources:=(ConsolidationArrayYTDTotalDailyAve), Function:=xlAverage我正在考虑下面的设计( do while循环在上面的For循环中--而不是试图表达思维过程的实际代码)：
Dim Im As Integer 'Same function as I when parsing through sheets
Dim FirstDay As Date 'first day of the month
Dim LastDay As Date 'last day of the month
Dim Month as Integer 'tracks active month 1 through 12
Dim RouteHrsSum As Single 'stores the sum of monthly Route Hours
Dim TotalHrsSum As Single 'stores the sum of monthly Total Hours
Month = 1 'set default month to January
Do While (ActiveCell >= FirstDay & ActiveCell <= LastDay) & Month <= 12
For Im = 2 to WS_Count
IF Month = 1 Then
FirstDay = 1/1/2016 & LastDay = 31/1/2016
ElseIF Month = 2 Then
FirstDay = 1/2/2016 & LastDay = 29/02/2016
ETC...
Else
FirstDay = 1/12/2016 & LastDay = 31/12/2016
Action: Scan a range of cells for dates for the active month
IF Date of Active Month found then sum cells A2, B2, C2 together, sum cells A9,B9,C9 together and write both sums to a pair of storage vairables (RouteHrsSum and TotalHrsSum respectively)
Else
Output RouterHrsSum & TotalHRsSum to respective cells on sheeet 1
Month = Month + 1 'Make next month active
'need to be able to recheck the last worksheet for a calendar month straddle and get data if so for new month's days
Next Im
Loop数据工作表示例：(截至8月19日的一周)
Driver Bob Monday Tuesday Wednesday Thursday Friday
15-Aug 16-Aug 17-Aug 18-Aug 19-Aug
Kilometres 318 91 119 219 394
Route Hours 5.74 4 2.5 4.25 6
Total Hours 9 9 9 9 10数据工作表示例：(跨日历月份的一周结束)
Driver Bob Monday Tuesday Wednesday Thursday Friday
29-Aug 30-Aug 31-Aug 1-Sept 2-Sept
Kilometres 300 110 119 89 394
Route Hours 7 4 2.5 4.25 6
Total Hours 9 9 9 9 9我觉得我在概念上是正确的，但当涉及到实际的代码和设计时，我总是陷入困境。任何帮助都是非常感谢的。如果这是含糊的，我很抱歉，但我不能只见树木不见森林。
当更清晰的内容出现时，我会很容易地编辑这个问题。
回答 1
Stack Overflow用户
回答已采纳
发布于 2016-08-31 22:22:38
我认为编译数据和使用consolidate一样简单。
Sub ProcessData()
Dim arTemp
Dim d As Date
Dim x As Long, y As Integer
Dim ws As Worksheet
Dim list As Object
Set list = CreateObject("System.Collections.SortedList")
For Each ws In Worksheets
If ws.Name <> "Summary" Then
With ws
For y = 2 To 6
d = DateSerial(Year(.Cells(2, y)), Month(.Cells(2, y)), 1)
If list.ContainsKey(d) Then
arTemp = list(d)
Else
ReDim arTemp(2)
End If
arTemp(0) = arTemp(0) + .Cells(3, y)
arTemp(1) = arTemp(1) + .Cells(4, y)
arTemp(2) = arTemp(2) + 1
list(d) = arTemp
Next
End With
End If
Next
With Worksheets("Summary")
.Cells.Delete
.Range("A1:F1") = Array("Year", "Month", "Avg. Kilometres", "Avg. Route Hours", "Sum Kilometres", "Sum Route Hours")
For x = 0 To list.Count - 1
d = list.GetKey(x)
.Cells(x + 2, 1) = Year(d)
.Cells(x + 2, 2) = Month(d)
.Cells(x + 2, 3) = list(d)(0) / list(d)(2)
.Cells(x + 2, 4) = list(d)(1) / list(d)(2)
.Cells(x + 2, 5) = list(d)(0)
.Cells(x + 2, 6) = list(d)(1)
Next
.Rows(x + 2).Columns("C:D").FormulaR1C1 = "=Average(R[-" & x & "]C:R[-1]C)"
.Rows(x + 2).Columns("E:F").FormulaR1C1 = "=Sum(R[-" & x & "]C:R[-1]C)"
.Columns("C:F").NumberFormat = "0.00"
.Columns.AutoFit
End With
End Sub页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://stackoverflow.com/questions/39240316
复制相关文章
相似问题
腾讯云开发者
