连续合并同一年的单元格

Question

我需要合并月份上方的单元格。 单元格应从 01 到 12 合并，在单元格中显示年份。

查找图片以获得更多说明。 我有下面的代码，但它显示在单元格 row1 中运行几个月后。 我的想法是通过 vba 将上述单元格转换为年份，并在同一年最后应用合并。 显示在所需的输出中。

注意。 第 4 行和第 5 行只是我的想法，这将有助于合并。

  Dim a(), i As Long, j As Long, m As Long, x As Range
  With Range("b1:qaz1")
    .MergeCells = False
    .ClearContents
    a() = .Offset(1).Value
    m = Month(a(1, 1))
    j = UBound(a, 2)
    Set x = .Cells(1)
    For i = 2 To j
      If m <> Month(a(1, i)) Or i = j Then
        With Range(x, .Cells(i - IIf(i = j, 0, 1)))
          .MergeCells = True
          .HorizontalAlignment = xlCenter
        End With
        x.Value = Format(DateSerial(2000, m, 1), "MMMM")
        m = Month(a(1, i))
        Set x = .Cells(i)
      End If
    Next
  End With
End Sub

运行新程序后输出的样子

Answer 1

由于您在标题行中有真实的日期，因此可以从那里提取月份和年份。但是，下面的代码会在处理之前将可能使用公式创建的日期转换为硬日期。

Sub MergeCaptionsByYear()
    ' 031

    Const CapsRow   As Long = 1                 ' change to suit
    Const StartClm  As Long = 2                 ' change to suit

    Dim Rng         As Range                    ' working range
    Dim Tmp         As Variant                  ' current cell's value
    Dim Cl          As Long                     ' last used column
    Dim Cstart      As Long                     ' first column in Rng
    Dim C           As Long                     ' working column
    Dim Yr          As Integer                  ' year

    Cl = Cells(CapsRow, Columns.Count).End(xlToLeft).Column
    Range(Cells(CapsRow, StartClm), Cells(CapsRow, Cl)).Copy
    Cells(CapsRow, StartClm).PasteSpecial xlValues
    Application.CutCopyMode = False

    C = StartClm - 1
    Application.DisplayAlerts = False
    Do
        Tmp = Cells(CapsRow, C + 1).Value
        If Not IsDate(Tmp) And (C <> Cl) Then
            MsgBox "Cell " & Cells(CapsRow, C + 1).Address(0, 0) & _
                   " doesn't contain a date." & vbCr & _
                   "This macro will be terminated.", _
                   vbInformation, "Invalid cell content"
            Exit Do
        End If

        If (Yr <> Year(CDate(Tmp))) Or (C = Cl) Then
            If Yr Then
                Set Rng = Range(Cells(CapsRow, Cstart), _
                                Cells(CapsRow, C))
                With Rng
                    .Merge
                    .HorizontalAlignment = xlCenter
                    .NumberFormat = "yyyy"
                End With
                SetBorder Rng, xlEdgeLeft
                SetBorder Rng, xlEdgeRight
            End If
            If C > (Cl - 1) Then Exit Do
            Cstart = C + 1
            Yr = Year(Tmp)
        End If
        C = C + 1
    Loop
    Application.DisplayAlerts = True
End Sub

Private Sub SetBorder(Rng As Range, _
                      Bord As XlBordersIndex)
    ' 031

    With Rng.Borders(Bord)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlMedium                          ' xlThin
    End With
End Sub

Answer 2

假设月份范围是“B5:AH5”

Sub test()

Dim monthsRng As Range
Set monthsRng = Range("B5:AH5")
monthsRng.Cells(1, 1).Offset(-1, 0).Select

For j = 1 To Int((monthsRng.Cells.Count / 12) + 2)
    If ActiveCell.Offset(1, 0) <> 0 Then
    For i = 1 To 12
        ActiveCell.Value = Year(ActiveCell.Offset(1, 0))
        If Year(ActiveCell.Offset(1, i)) = ActiveCell Then
        Selection.Resize(1, i + 1).Select
        Else
        Exit For
        End If
    Next
        With Selection
            .HorizontalAlignment = xlCenter
            .MergeCells = True
        End With
    Selection.Offset(0, 1).Select
    Else
    Exit For
    End If
Next

End Sub

无论上述过程中Range("B5:AH5") 中的日期是否格式化为日期，都可以用下面的代码替换内部for 循环。

For i = 1 To 12
    ActiveCell.Value = Right(Format(ActiveCell.Offset(1, 0), "DD.MM.YYYY"), 4)
    If Right(Format(ActiveCell.Offset(1, i), "DD.MM.YYYY"), 4) = Format(ActiveCell, Text) Then
    Selection.Resize(1, i + 1).Select
    Else
    Exit For
    End If
Next

但是，在任何情况下，您都需要将 excel 中的输出格式化为数字（没有 1000 个分隔符和小数位）而不是日期。