vba - 需要按顺序写出月份

Question

我有一个以月/年为标题的列列表(例如 JAN09、FEB09、AUG10)。我必须检查月份是否按顺序对齐。如果没有，则将其对齐，如果特定月份不可用，则创建列名称标题作为月份名称并继续。我已经编写了一个代码，但它在第一年有效(比如从 09-11 年，它将识别 09 的所有月份，但之后它无法识别并每次创建一个新月份，即使它存在)。

Sub MonthFinder()
    Dim montharray As Variant

    montharray = Array("JAN", "FEB", "MAR", "APR", "MAY", "JUN", "JUL", "AUG", "SEP", "OCT", "NOV", "DEC")

    lastrow = ActiveSheet.UsedRange.Rows.Count + 5
    lastcol = ActiveSheet.UsedRange.Columns.Count
    minmonth = Right(Cells(5, 2), 2)
    range0 = 2
    maxmonth = Right(Cells(5, 2), 2)

    Do Until range0 > lastcol
        If Right(Cells(5, range0), 2) < minmonth Then
            minmonth = Right(Cells(5, range0), 2)
        End If

        If Right(Cells(5, range0), 2) > maxmonth Then
            maxmonth = Right(Cells(5, range0), 2)
        End If
        range0 = range0 + 1
    Loop

    minsortmonth = minmonth
    maxsortmonth = maxmonth

    place = 2

    Do Until minsortmonth = maxsortmonth + 1
        arraycount = 0

        Do Until arraycount = 12
            range1 = 2
            lastcol = ActiveSheet.UsedRange.Columns.Count

            Do Until Left(Cells(5, range1), 3) = montharray(arraycount) And Right(Cells(5, range1), 2) = minsortmonth Or range1 > lastcol
                range1 = range1 + 1
            Loop

            If range1 > lastcol Then
                Range(Cells(5, place), Cells(lastrow, place)).Select
                Selection.Insert Shift:=xlToRight
                Cells(5, place).Value = montharray(arraycount) & minsortmonth
            Else
                If range1 <> place Then
                    Range(Cells(5, range1), Cells(lastrow, range1)).Cut
                    Cells(5, place).Select
                    Selection.Insert Shift:=xlToRight
                End If
            End If
            arraycount = arraycount + 1
            place = place + 1
        Loop

        minsortmonth = minsortmonth + 1
    Loop

End Sub

Answer 1

我建议更改您所做的逻辑并使用 Dictionary .

假设您的数据(列)最初排序如下:JAN09、FEB09、APR09...MAR00、MAY00、JUL00、...等。月份收集存在一些间隙并且您想填补缺失的月份。这是一个想法:

'Note: columns are initially sorted!
Sub CheckMonthSequence()
Dim dic As Dictionary
Dim element As Variant
Dim col As Integer, pos As Integer, rng As Range
Dim initialDate As Date, endDate As Date, sTmp As String

Set rng = ThisWorkbook.Worksheets("Sheet1").Range("B5")
'define initial date as January of ...
sTmp = rng
sTmp = "01/01/" & "20" & Right(sTmp, 2)
initialDate = CDate(sTmp)
'define end date
sTmp = rng.End(xlToRight)
sTmp = Left(sTmp, 3) & "/01/" & "20" & Right(sTmp, 2)
endDate = CDate(sTmp)

'create new dictionary with collection of months
Set dic = GetMonthsAsDictionary(initialDate, endDate)
'define a range of columns to sort and update
col = 0
Do While rng.Offset(, col) <> ""
    element = rng.Offset(, col)
    If dic.Exists(element) Then
        pos = dic.Item(element)
        If pos > col Then
            Do While col < pos
                rng.Offset(, col).EntireColumn.Insert xlShiftToRight
                'sometimes it loses the reference, so...
                Set rng = ThisWorkbook.Worksheets("Sheet1").Range("B5")
                rng.Offset(, col) = GetKeyByIndex(dic, col)
                col = col + 1
            Loop
            col = pos
        End If
    End If
    col = col + 1
Loop


End Sub


'needs reference to MS Scripting Runtime
Function GetMonthsAsDictionary(ByVal StartingMonth As Date, EndMonth As Date) As Dictionary
Dim dic As Dictionary
Dim i As Integer, j As Integer

'create new dictionary
Set dic = New Dictionary
i = 0
j = DateDiff("M", StartingMonth, EndMonth)
For i = 0 To j
    dic.Add UCase(Format(DateAdd("M", i, StartingMonth), "MMMyy")), i
    Debug.Print UCase(Format(DateAdd("M", i, StartingMonth), "MMMyy")), i
Next

Set GetMonthsAsDictionary = dic

End Function

Function GetKeyByIndex(ByVal dic As Dictionary, ByVal ind As Integer) As String
Dim dic_Keys As Variant, element As Variant

dic_Keys = dic.keys
For Each element In dic_Keys
    If dic.Item(element) = ind Then
        Exit For
    End If
Next

GetKeyByIndex = element

End Function

如您所见，上面的代码:
1) 创建包含月份和相应索引的字典。
2) 循环遍历列集合
3) 检查值是否对应于字典中的索引
4)必要时填写标题。

我知道，它并不完美，但这是一个很好的起点。

干杯
Maciej

[编辑]

使用您的逻辑，代码可能如下所示:

Option Explicit 'do not apply initialize variable without its declaration

Sub MonthFinder()
Dim montharray As Variant, rng As Range
Dim firstyear As Integer, lastyear As Integer, curryear As Integer
Dim curroffset As Integer, lastcol As Integer, currmonth As Integer

curroffset = 0
montharray = Array("JAN", "FEB", "MAR", "APR", "MAY", "JUN", "JUL", "AUG", "SEP", "OCT", "NOV", "DEC")

'start here:
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("B5")
'first year
firstyear = CInt(Right(rng, 2))
'fid last col
lastcol = rng.End(xlToRight).Column - rng.Column
'find last year
lastyear = CInt(Right(rng.Offset(ColumnOffset:=lastcol), 2))

For curryear = firstyear To lastyear
    For currmonth = LBound(montharray) To UBound(montharray)
        'if current month is equal to last month - exit for
        If CStr(montharray(currmonth) & curryear) = CStr(rng.End(xlToRight)) Then Exit For
        'month is proper - do nothing
        If rng.Offset(ColumnOffset:=curroffset) = CStr(montharray(currmonth) & curryear) Then GoTo SkipMonth
        'other cases
        rng.Offset(ColumnOffset:=curroffset).EntireColumn.Insert xlShiftToRight
        Set rng = ThisWorkbook.Worksheets("Sheet1").Range("B5")
        rng.Offset(ColumnOffset:=curroffset) = CStr(montharray(currmonth) & curryear)
SkipMonth:
        curroffset = curroffset + 1
    Next
Next

Set rng = Nothing

End Sub

干杯，
马切伊