拼合逐月数据系列

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

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