拼合逐月数据系列

近期数据处理中搜集到一个地方的降雨数据按月排列，如下表所示：

Station	Year	Type	Month	1	2	3	4	…	29	30	31
BJ0030C	1961	Precip	01	0	0	0	0	…	0	0	0
BJ0030C	1962	Precip	01	0	0	0	0	…	0	0	0
BJ0030C	1963	Precip	01	0	0	0	0	…	0	0	0
BJ0030C	1964	Precip	01	0	0	0	0	…	0	0	0
BJ0030C	1965	Precip	01	0	0	0	0	…	0	0	0
BJ0030C	1966	Precip	01	0	0	0	0	…	0	0	0
BJ0030C	1967	Precip	01	0	0	0	0	…	0	0	0
BJ0030C	1968	Precip	01	0	0	0	0	…	0	0	0
BJ0030C	1969	Precip	01	0	0	0	0	…	0	0	0
BJ0030C	1970	Precip	01	0	0	0	0	…	0	0	0

为了得到逐日的数据序列，编写了以下宏代码：

Public Sub CombineDates()
    Dim wsSrc As Worksheet, wsResult As Worksheet
    Dim s1 As String, s2 As String
    Dim i As Integer
    Dim InvalidSheet As Boolean
    
    Set wsSrc = ActiveSheet
    'Check source format
    InvalidSheet = False
    If wsSrc.Cells(1, 1).Text <> "Station" Then InvalidSheet = True
    If wsSrc.Cells(1, 2).Text <> "Year" Then InvalidSheet = True
    If wsSrc.Cells(1, 3).Text <> "Type" Then InvalidSheet = True
    If wsSrc.Cells(1, 4).Text <> "Month" Then InvalidSheet = True
    For i = 1 To 31
            If wsSrc.Cells(1, 4 + i).Text <> i Then InvalidSheet = True
    Next
    If InvalidSheet Then
        MsgBox "Invalid source sheet." & vbCrLf & "The first row of the sheet must be: " & vbCrLf & _
            "Eg gh id,Year,Eg el abbreviation,Month,1...31", vbCritical
        Exit Sub
    End If

    'Create the result sheet
    s1 = wsSrc.Name & "_Rlt"
    On Error Resume Next
    s2 = s1
    i = 1
    Do
        Set wsResult = Nothing
        Set wsResult = ActiveWorkbook.Sheets(s2)
        If wsResult Is Nothing Then Exit Do
        s2 = s1 & "(" & i & ")"
        i = i + 1
    Loop
    On Error GoTo 0
    Set wsResult = ActiveWorkbook.Sheets.Add(, wsSrc)
    wsResult.Name = s2
    
    'Convert
    wsResult.Cells(1, 1).Value = "Station"
    wsResult.Cells(1, 2).Value = "Date"
    wsResult.Cells(1, 3).Value = wsSrc.Name
    wsResult.Columns(2).ColumnWidth = 12
    Dim rowIdx As Long, rowIdxRlt As Long, curYear As Integer, curMonth As Integer
    rowIdx = 2
    rowIdxRlt = 2
    While Not IsEmpty(wsSrc.Cells(rowIdx, 1))
        s1 = wsSrc.Cells(rowIdx, 1).Text
        curYear = wsSrc.Cells(rowIdx, 2).Value
        curMonth = wsSrc.Cells(rowIdx, 4).Value
        For i = 1 To 31
            If IsEmpty(wsSrc.Cells(rowIdx, i + 4)) Then Exit For
            wsResult.Cells(rowIdxRlt, 1).Value = s1
            wsResult.Cells(rowIdxRlt, 2).Value = DateSerial(curYear, curMonth, i)
            wsResult.Cells(rowIdxRlt, 3).Value = wsSrc.Cells(rowIdx, i + 4).Value
            rowIdxRlt = rowIdxRlt + 1
        Next
        rowIdx = rowIdx + 1
    Wend
    MsgBox "In total " & (rowIdxRlt - 2) & " records were generated.", vbInformation, "Congratulation"
End Sub