一つのセル内に複数行のテキストがあるバチクソ汚いエクセルを、VBAマクロできれいに分割するには

あぶすとらくと

とあるexcelをみたとき、次のように１つのセルに改行で複数のテキストがあって何か加工処理を行うのがだるいとバチクソ発狂したことはないだろうか。
俺はあります。アァァァーー。

そんなとき、VBAマクロでサクッと分割すれば良いじゃないかと考えました。次のように。

それでいってみましょう。

どうすれば良いか

こうします。

Sub ボタン_click()
    Dim rng As Range
    Dim cell As Range
    Dim arr As Variant
    Dim i As Long
    Dim shiftCount As Long
    
    ' 対象となるセル範囲を選択
    On Error Resume Next
    Set rng = Application.InputBox("分割したいセル範囲を選択してください", Type:=8)
    On Error GoTo 0
    
    If rng Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' 下から上にループ（行の挿入に対応するため）
    For i = rng.Rows.Count To 1 Step -1
        Set cell = rng.Cells(i, 1)
        
        ' 改行コード（vbLf）で分割
        If InStr(cell.Value, vbLf) > 0 Then
            arr = Split(cell.Value, vbLf)
            
            ' 分割された数だけ行を挿入
            cell.Offset(1).Resize(UBound(arr)).EntireRow.Insert Shift:=xlDown
            
            ' 罫線を保持するため、元の行の書式をコピー
            cell.EntireRow.Copy
            cell.Offset(1).Resize(UBound(arr)).EntireRow.PasteSpecial Paste:=xlPasteAll
            
            ' 分割した値を各行にセットし、色付け
            Dim j As Long
            For j = 0 To UBound(arr)
                cell.Offset(j).Value = arr(j)
                If j > 0 Then
                    ' 追加された行（変更箇所）のセルを黄色（色番号: 6）で色付け
                    cell.Offset(j).Interior.ColorIndex = 6
                End If
            Next j
        End If
    Next i
    
    Application.CutCopyMode = False
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

ポイントとしては、次の行です。xlPasteAll を渡してやることで、行内のすべてをコピーできます。

cell.Offset(1).Resize(UBound(arr)).EntireRow.PasteSpecial Paste:=xlPasteAll