<Excel>データを整形するマクロ

まえがき

仕事でやむを得ず作成したExcelマクロです。
使い捨てで作成したのですが、似たようなことは今後もあり得るかもと思い投稿しています。

バージョン

Excel 2022

処理概要

マクロを登録し、挿入したボタンにマクロを登録しました。
あとはデータを用意して、ボタンをクリックすれば下記の処理が実行されます。

• 実行するExcelファイルのシートにある特定の範囲セルのデータをコピーする
• 文字列を縦書きから横書きへ変更する
• 貼り付け先のデータを削除する
• 横並びのデータを立て並びへ変換する
• データを特定のセルへ張り付ける
• 全角 （） を半角 () に置換する
• コピー元のデータを削除する
• 完了のメッセージボックスを表示させる

Excel Macro

Sub TransformAndReplace()
    Dim ws As Worksheet
    Dim rngSource As Range
    Dim rngTarget As Range
    Dim cell As Range
    Dim lastCol As Integer
    Dim dataArray As Variant
    Dim rowCount As Integer

    On Error GoTo ErrorHandler ' エラーハンドリング開始

    ' アクティブなワークシートを取得
    Set ws = ActiveSheet

    ' シートが正しく取得できない場合のエラーチェック
    If ws Is Nothing Then
        MsgBox "アクティブなシートが見つかりません", vbExclamation
        Exit Sub
    End If

    ' シート名をデバッグ出力
    Debug.Print "アクティブシート：" & ws.Name

    ' F2:OO2 のデータ範囲を取得（最も右のデータ列を特定）
    lastCol = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column
    
    ' データがない場合は処理を終了
    If lastCol < 6 Then
        MsgBox "コピー元にデータがありません", vbExclamation
        Exit Sub
    End If

    ' コピー元のデータ範囲を設定（F2～最後の列）
    Set rngSource = ws.Range(ws.Cells(2, 6), ws.Cells(2, lastCol))

    ' 文字列の方向を 0 度に設定（縦書きを横書きに変更）
    rngSource.Orientation = 0

    ' C3:C403 のデータを削除（セルを空にする）
    Debug.Print "C3:C403 のクリアを実行"
    ws.Range("C3:C403").ClearContents
    DoEvents ' 画面更新を強制

    ' データを配列に格納し、行数を取得
    dataArray = Application.Transpose(rngSource.Value)
    rowCount = UBound(dataArray)

    ' データが400行を超える場合はエラー表示
    If rowCount > 401 Then
        MsgBox "貼り付けるデータが多すぎます (最大400行)", vbExclamation
        Exit Sub
    End If

    ' C3 に行列を入れ替えてデータを貼り付け
    Set rngTarget = ws.Range("C3")
    rngTarget.Resize(rowCount, 1).Value = dataArray

    ' C3:C403 のデータに対して全角 ( ) を半角 ( ) に置換
    For Each cell In ws.Range("C3:C403")
        If Not IsEmpty(cell.Value) And Not IsError(cell.Value) Then
            cell.Value = Replace(cell.Value, "（", "(")
            cell.Value = Replace(cell.Value, "）", ")")
        End If
    Next cell

    ' F2:OO2 のデータを削除（セルの内容のみ削除し、左シフトはしない）
    rngSource.ClearContents

    ' 成功メッセージを表示
    MsgBox "マクロを実行しました", vbInformation

    Exit Sub

ErrorHandler:
    ' エラー時の処理
    MsgBox "Error!", vbCritical
End Sub