Question

我现在正在创建一个基于月/季度的日历，我正在进行最后的步骤，我需要弄清楚的最后一件事是如何将单元格与重复值组合并合并它们以便它们流过日历流畅。

我现在拥有的内容：

我想要的是什么：

我是一名新手VBA程序员，但对C＃有一些经验，所以我一直在寻找并整理这段代码，但我不确定我的逻辑是否合适，或者它是否正常运行：

Option Explicit

Public Sub MergeContiguousValues(col As Long)

   Dim start As Range
   Dim finish As Range


   Set start = Cells(1, col)
   Set finish = start

   Application.DisplayAlerts = False

   Do While start <> ""

      Do While start = finish.Offset(1, 0)
         Set finish = finish.Offset(1, 0)
      Loop

      If start.Address <> finish.Address Then
         Range(start, finish).Merge
         Range(start, finish).VerticalAlignment = xlCenter
      End If

      Set start = finish.Offset(1, 0)
      Set finish = start

   Loop

   Application.DisplayAlerts = True

End Sub

有关如何执行此操作的任何建议？或者我哪里出错？

我正在使用=IF(ISNUMBER(FIND公式来提取日历，从单独的工作表中提取信息，这些工作表会从报名表中提取数据。

Answer 1

我认为这是你正在寻找的东西。我在一个空白工作表中测试了它，在A1到D1的单元格中具有相同的值...希望这有帮助！

Option Explicit

Public Sub MergeContiguousValues()

Dim start As Range
Dim finish As Range
Dim sVal As String
Dim fVal As String

'replace Cells(1, 1) with your passed variables
Set start = Cells(1, 1)
Set finish = start

'set values for the starting and finishing cell
sVal = start.Value
fVal = finish.Value

'check each column until the name is no longer the same
Do While sVal = fVal

    Set finish = finish.Offset(0, 1)
    fVal = finish.Value

Loop

'backup one column
Set finish = finish.Offset(0, -1)

'clear all values and only place value in start range
Range(start, finish).Value = ""
Range(start.Address).Value = sVal

'instead of merging, how about aligning across the start and finish range
Range(start, finish).HorizontalAlignment = xlCenterAcrossSelection

End Sub

Answer 2

我使用Areas对象的Range属性，如下所示：

Public Sub MergeContiguousValues(calendarColumns As Range, calendarStartRow As Long)
    Dim i As Long
    Dim area As Range

    Application.DisplayAlerts = False
    With calendarColumns
        For i = calendarStartRow To LastRow(calendarColumns, calendarStartRow)
            If WorksheetFunction.CountA(.Rows(i)) > 0 Then
                For Each area In .Rows(i).SpecialCells(xlCellTypeFormulas).Areas
                    With area
                        .Merge
                        .VerticalAlignment = xlCenter
                    End With
                Next area
            End If
        Next i
    End With
    Application.DisplayAlerts = True
End Sub

以及LastRow()函数：

Function LastRow(rng As Range, minRow As Long) As Long
    With rng.Parent
        With Intersect(.UsedRange, rng.columns).SpecialCells(xlCellTypeFormulas)
            LastRow = .Areas(.Areas.Count).Row
        End With
    End With
    If LastRow < minRow Then LastRow = minRow
End Function

根据您的示例，可能的用法可能是：

Sub main()
    MergeContiguousValues Worksheets("calendar").Range("D:O"), 4
End Sub

我假设＆＃34;日历＆＃34;作为包含日历的工作表的名称：根据您的需要进行更改

修复宏以组合连续值

2 个答案: