Merge, Unmerge, Remerge Makro

Question

Ich arbeite an einem Makro, um zusammengeführte Zellen in einem bestimmten Bereich aufzulösen und die ursprünglichen zusammengeführten Zellen, die nicht zusammengeführt wurden, erneut zusammenzuführen. Ich habe gekämpft, um zu identifizieren, wie man eine Liste der Zellen speichert, die zuerst nicht zusammengefügt werden, damit das Makro diese genauen Zellen wieder zusammenführen kann. Die Zeilen, die in der Tabelle zusammengeführt werden, ändern sich von Woche zu Woche.

Sub MergeUnmerge() 

' 

Mergeunmerge Macro 
' 

Dim mergelist As Range 

Dim celllist As Range 


For Each cell In Range("A1:S49") 

If cell.MergeCells = True Then 
    Set mergelist = celllist 
      cell.UnMerge 
     End If 
    Next 

For Each cell In mergelist 
    Range("celllist").Merge 
Next 

End Sub

Answer 1

müssen Sie:

• Verwendung mergeCells Eigenschaft für verbundene Zellen zu überprüfen

• Verwendung Gebiete Eigenschaft Range Objekt

• Verwendung Merge Methode Bereiche zu verschmelzen zurück

wie folgt

Option Explicit 

Sub MergeUnmerge() 
    Dim mergedCells As Range 
    Dim cell As Range 

    With Range("A1:S49") '<--| reference your range 
     Set mergedCells = .Offset(.Rows.Count, .Columns.Count).Resize(1, 1) '<--| initialize mergedCells range to a spurious cell out of referenced range 
     For Each cell In .Cells '<--|loop through referenced range cells 
      If cell.mergeCells Then '<--| if current cell belongs to a merged area 
       Set mergedCells = Union(mergedCells, cell.MergeArea) '<--| update 'mergedCells' range 
       cell.UnMerge '<--| unmerge it 
      End If 
     Next 

     Set mergedCells = Intersect(mergedCells, .Cells) '<--| filter out the spurious cell 
     If Not mergedCells Is Nothing Then '<--| if there's some cell left 
      For Each cell In mergedCells.Areas '<--| loop through areas 
       cell.Merge '<--| merge curent area 
      Next 
     End If 
    End With 
End Sub 

Answer 2

Sie werden die MergeArea Adresse zu einem Array hinzufügen müssen.

Sub MergeUnmerge() 

Dim cel As Range 
Dim mergeArr() 
y = 0 

For Each cel In Range("A1:S49") 
    If cel.MergeCells = True Then 
     ReDim Preserve mergeArr(y + 1) 
     mergeArr(y + 1) = cel.MergeArea.Address 
     cel.UnMerge 
     y = y + 1 
    End If 
Next cel 

For x = 1 To y 
    Range(mergeArr(x)).Merge 
Next x 

End Sub