Excelマクロ スクラップ

' 結合セルを解除し、分解後のセルに同じ値を入力する

Public Sub UnMergeCells()
    Dim sel As range
    Dim merged_cells As range
    ' 選択しているものが範囲の時のみ処理する
    If TypeName(Selection) = "Range" Then
                
        Set sel = Selection
        
        ' 選択しているセルから結合されているセルのみを抽出
        Dim c As range
        For Each c In sel
            If c.MergeCells Then
            
                If merged_cells Is Nothing Then
                    Set merged_cells = c
                Else
                
                    Set merged_cells = Union(merged_cells, c)
                End If
            Else
            
            End If
        Next c
        
        
        ' エリアごとにセルを分解
        Dim a As range
        For Each a In merged_cells.Areas
        
            For Each c In a
                If c.MergeCells Then
                    Dim ma As range
                    Set ma = c.MergeArea
                    ma.UnMerge
                    ma.Formula = c.Cells(1, 1).Formula
                
                
                End If
            Next c
        Next a
        
    End If
End Sub

' 選択しているセル範囲にたいして
' Trim と Cleanを適用する
Public Sub CleanAndTrim()
    
    Dim sel As range
    
    If TypeName(Selection) = "Range" Then
        
        Set sel = Selection
        
        Dim c As range
        For Each c In sel.Cells
            
            Dim f As String
            f = c.Formula
            
            f = WorksheetFunction.Trim(f)
            f = WorksheetFunction.Clean(f)
            
            c.Formula = f
        Next c
    End If
    
End Sub

' 選択したセルが結合されている場合に結合を
' 解除して結合後のセルの値に全て同じ値を入力する

Public Sub ExtractMergedCells()
    
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    Dim dict As Dictionary
    Set dict = New Dictionary
    
    Dim usedCells As Range
    Dim mergedArea As Range
    Dim c As Range
    
    Dim address As String
    Dim col As Collection
    
    If TypeName(Selection) = "Range" Then
        
        Dim sel As Range
        Set sel = Selection
        
        Set usedCells = sel.SpecialCells(xlCellTypeConstants)
        
        
        Dim i As Long
        For i = 1 To usedCells.Count
            Set c = sel(i)
            
            ' セルが結合されている場合
            If c.MergeCells Then
                
                ' 結合範囲でグループ分け
                address = c.MergeArea.address
                
                If Not dict.Exists(address) Then
                    
                    Set mergedArea = ws.Range(address)
                    
                    Call ExtractMergedCell(mergedArea)
                End If
            End If
        Next i
    End If
End Sub


Private Sub ExtractMergedCell(mergedCell As Range)
    Dim value As Variant
    value = mergedCell(1).value
    
    Dim address As String
    address = mergedCell.address
    
    Dim ws As Worksheet
    Set ws = mergedCell.Worksheet
    
    mergedCell.UnMerge
    
    ws.Range(address).value = value
End Sub