将数据从每月转换为每日

Question

场景：我有一个从其他文件读取数据并导入到不同工作表的代码。其中一些文件具有月度格式的数据，而另一些则具有每日格式的数据

每日数据示例（yyyy-mm-dd）：

              item1    item2    item3
2010/01/01    1         1         1
2010/01/02    1         1         1
2010/01/03    1         1         1
2010/01/04    1         1         1
2010/01/05    1         1         1

数据示例monthly(yyyy-mm-dd)，这里的日期通常是当月的最后一个工作日：

              item1    item2    item3
2010/01/31    5          3        1
2010/02/28    4          10       5
2010/03/31    7          9        2
2010/04/30    8          4        8
2010/05/31    2          7        7

目标：我正在尝试将所有月度数据转换为每日数据，方法是保持月末所有日期的月末值相同。例如：如果我 2010/02/28 的值是 10，则 2 月的所有天数都应该等于该项目的 10。

我已经尝试过的方法：我尝试过反向循环并添加列，但没有奏效。现在我正在尝试创建两个数组（一个每天和一个每月），并比较：遍历每月行，然后每天行，如果月份和年份相同，则使该每日行的值等于每月（例如：2 月的所有日值都将等于 1 月的月值，除了 2 月的最后一天，它将是 2 月的月值）。比如：

如果我的项目 1 一月的月值为 5，二月的月值为 10，三月的月值为 3，那么我的每日数据将是（假设我的数据从 1 月开始）：

01/01 至 30/01 = 5、31/01 至 27/02 = 10、28/02 至 30/03 = 3，依此类推。

问题：当我尝试这样做时，我无法正确组织循环，因此 xx 循环（用于列）最终会从错误的行中获取数据。知道如何解决这个问题，或者如何以更有效的方式进行此过程吗？

代码：

Private Sub CommandButton2_Click()

Dim monthlydatesarray As Variant, monthlydataarray As Variant, dailydatesarray As Variant, dailydataarray As Variant
Dim xx As Long, monthlydaterow As Long, dailydaterow As Long, lastRowD As Long, lastRowM As Long
Dim wbpath As String
Dim wb As Workbook
Dim ws As Worksheet

wbpath = ThisWorkbook.Path
Set wb = ThisWorkbook

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

lastRowD = Sheets("Bid").Cells.SpecialCells(xlCellTypeLastCell).Row
lastRowM = Sheets("AMT").Cells.SpecialCells(xlCellTypeLastCell).Row

For Each ws In wb.Worksheets
    If ws.Name = "A" Then
        'sets proper columns for dates and data, both monthly and daily
        dailydatesarray = wb.Sheets("B").Range("A2:A" & lastRowD)
        dailydataarray = wb.Sheets("B").UsedRange
        monthlydatesarray = wb.Sheets("A").Range("A2:A" & lastRowM)
        monthlydataarray = wb.Sheets("A").UsedRange

        'if date matches month and year, use the data values
        For monthlydaterow = 1 To UBound(monthlydatesarray)
            For dailydaterow = 1 To UBound(dailydatesarray)
                If Month(monthlydatesarray(monthlydaterow, 1)) = Month(dailydatesarray(dailydaterow, 1)) And Year(monthlydatesarray(monthlydaterow, 1)) = Year(dailydatesarray(dailydaterow, 1)) Then
                    'loop the columns to paste the monthly data into daily array
                    For xx = 2 To UBound(dailydataarray, 2)
                        dailydataarray(dailydaterow + 1, xx) = monthlydataarray(monthlydaterow, xx)
                    Next xx
                End If
            Next dailydaterow
        Next monthlydaterow

        'do one more loop to repaste the last date of the month properly            
        For monthlydaterow = 1 To UBound(monthlydatesarray)
            For dailydaterow = 1 To UBound(dailydatesarray)
                If monthlydatesarray(monthlydaterow) = dailydatesarray(dailydaterow) Then
                    For xx = 2 To UBound(dailydataarray, 2)
                        dailydataarray(dailydaterow, xx) = monthlydataarray(monthlydaterow, xx)
                    Next xx
                End If
            Next dailydaterow
        Next monthlydaterow

            ws.UsedRange.Clear
            wb.Sheets("B").Range("A1").Resize(UBound(dailydataarray, 1), UBound(dailydataarray, 2)) = dailydataarray
            ws.UsedRange.Columns(1).NumberFormat = "yyyy/mm/dd"

    End If
Next ws

'Optimize Macro Speed End
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic

MsgBox "Process Finished"

End Sub

Answer 1

尝试以下方法，如果您想适应，请告诉我。应该真正动态地确定最后一列。甚至可以使用 UsedRange，但让我们看看这是否适用于初学者。假设数据以 A1 中的标题开头。我也许可以考虑更多，但现在是海滩时间！

注意：最后，您可能希望将数组输出到其他地方，以免覆盖现有数据（我相信它有更多列）

如果您还想在上个月进行填充，请使用版本 1。如果您想排除上个月的填充，请使用版本 2。请确保在两个版本中都使用该功能。另外，确保输出第一列的格式为日期。

版本 1

Option Explicit

Public Sub RepeatData1()

Dim wb As Workbook
Dim ws As Worksheet
Dim lastRow As Long
Dim sourceData As Range

Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet7") 'change
lastRow = ws.Cells(ws.Rows.count, "A").End(xlUp).Row 'change to appropriate column to get last row
Set sourceData = ws.Range("A2:D" & lastRow) 'change to get include last column

Dim inputArray()
Dim totalOutRows As Long
Dim i As Long

inputArray = sourceData.Value2

For i = 1 To UBound(inputArray, 1)
    totalOutRows = totalOutRows + GetDaysInMonth(Application.WorksheetFunction.EoMonth(inputArray(i, 1), 1))
Next i

Dim outputArray()
ReDim outputArray(1 To totalOutRows, 1 To UBound(inputArray, 2))
Dim outputRow As Long

outputRow = 1

Dim j As Long

For i = 1 To UBound(inputArray, 1)

    For j = 1 To UBound(inputArray, 2)
        outputArray(outputRow, j) = inputArray(i, j)
    Next j

    Dim k As Long

    For k = 1 To GetDaysInMonth(Application.WorksheetFunction.EoMonth(inputArray(i, 1), 1))

        For j = 1 To UBound(inputArray, 2)

            If j = 1 And outputRow > 1 Then
                outputArray(outputRow, j) = inputArray(i, j) + k - 1
            Else
                outputArray(outputRow, j) = inputArray(i, j)
            End If

        Next j

    outputRow = outputRow + 1

    Next k

Next i


ws.Range("L2").Resize(UBound(outputArray, 1), UBound(outputArray, 2)).Value = outputArray

End Sub

Public Function GetDaysInMonth(ByVal datum As Double) As Long
    GetDaysInMonth = Day(DateSerial(Year(datum), Month(datum) + 1, 1) - 1)
End Function

版本 2：

Option Explicit

Public Sub RepeatData()

Dim wb As Workbook
Dim ws As Worksheet
Dim lastRow As Long
Dim sourceData As Range

Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet7") 'change
lastRow = ws.Cells(ws.Rows.count, "A").End(xlUp).Row 'change to appropriate column to get last row
Set sourceData = ws.Range("A2:D" & lastRow) 'change to get include last column

Dim inputArray()
Dim totalOutRows As Long
Dim i As Long

inputArray = sourceData.Value2

For i = 2 To UBound(inputArray, 1)   
    totalOutRows = totalOutRows + GetDaysInMonth(inputArray(i, 1))   
Next i

totalOutRows = totalOutRows + 1

Dim outputArray()
ReDim outputArray(1 To totalOutRows, 1 To UBound(inputArray, 2))
Dim outputRow As Long

outputRow = 1

Dim j As Long

For i = 1 To UBound(inputArray, 1) - 1

    For j = 1 To UBound(inputArray, 2)     
        outputArray(outputRow, j) = inputArray(i, j)     
    Next j

    Dim k As Long

    For k = 1 To GetDaysInMonth(inputArray(i + 1, 1))

        For j = 1 To UBound(inputArray, 2)

            If j = 1 And outputRow > 1 Then
                outputArray(outputRow, j) = inputArray(i, j) + k - 1
            Else
                outputArray(outputRow, j) = inputArray(i, j)
            End If

        Next j

    outputRow = outputRow + 1

    Next k

Next i

For j = 1 To UBound(inputArray, 2)
    outputArray(UBound(outputArray, 1), j) = inputArray(UBound(inputArray, 1), j)
Next j

ws.Range("L2").Resize(UBound(outputArray, 1), UBound(outputArray, 2)).Value = outputArray

End Sub