修復宏以結合連續值

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

我會使用Range對象的Areas性質類似如下：

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 

其中我假設「日曆」作爲工作表的名稱與日曆：根據您的需要更改它

Answer 2

我想這就是你要找的。我在一個空白的工作表中測試了它，在單元格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