業務で役立つ便利マクロ5選！

この記事ではマクロ（VBA）を使用します。
マクロ初挑戦の方はこちらの記事からスタートすることをお勧めします。
Excelのマクロ初期設定ガイド

---

---

🔨 VBAマクロ：選択範囲を罫線を除いて入れ替え

Sub SwapRangesWithoutBorders()
    Dim rng1 As Range, rng2 As Range
    Dim tempArr1 As Variant, tempArr2 As Variant
    Dim ws As Worksheet
    
    ' シートの指定（アクティブシート）
    Set ws = ActiveSheet
    
    ' 選択範囲を確認（2つの範囲を選択する）
    On Error Resume Next
    Set rng1 = Application.InputBox("1つ目の範囲を選択してください", Type:=8)
    Set rng2 = Application.InputBox("2つ目の範囲を選択してください", Type:=8)
    On Error GoTo 0
    
    ' 範囲が選択されていない場合
    If rng1 Is Nothing Or rng2 Is Nothing Then
        MsgBox "範囲を正しく選択してください。", vbExclamation
        Exit Sub
    End If
    
    ' 範囲サイズの確認
    If rng1.Cells.Count <> rng2.Cells.Count Then
        MsgBox "範囲のサイズが一致しません。", vbExclamation
        Exit Sub
    End If
    
    ' 一時保存用の配列に値・書式を格納（罫線は除外）
    tempArr1 = rng1.Value
    tempArr2 = rng2.Value
    
    ' 値を入れ替え
    rng1.Value = tempArr2
    rng2.Value = tempArr1
    
    ' 書式を入れ替え
    Dim cell1 As Range, cell2 As Range
    Dim i As Integer
    
    For i = 1 To rng1.Cells.Count
        Set cell1 = rng1.Cells(i)
        Set cell2 = rng2.Cells(i)
        
        ' 背景色・フォント・数値書式を交換
        Dim tempInterior As Variant, tempFont As Variant, tempNumberFormat As Variant
        
        tempInterior = cell1.Interior.Color
        tempFont = cell1.Font.Color
        tempNumberFormat = cell1.NumberFormat
        
        cell1.Interior.Color = cell2.Interior.Color
        cell1.Font.Color = cell2.Font.Color
        cell1.NumberFormat = cell2.NumberFormat
        
        cell2.Interior.Color = tempInterior
        cell2.Font.Color = tempFont
        cell2.NumberFormat = tempNumberFormat
    Next i
    
    MsgBox "選択範囲を罫線を維持したまま入れ替えました！", vbInformation
End Sub

---

このマクロのポイント

✔ 選択した2つの範囲のデータを交換（罫線は維持）
✔ 背景色・フォント・数値書式なども入れ替え
✔ セルの数が一致しないとエラーを表示
✔ 安全に動作するようにエラーハンドリング付き

使い方

1. マクロを実行（SwapRangesWithoutBorders を実行）
2. 1つ目の範囲を選択 → OK
3. 2つ目の範囲を選択 → OK
4. 罫線を維持したままデータ・書式が入れ替わる！

---

🔨 VBAマクロ：指定したキーワードを含む行を抽出・コピー

マクロの仕様

• ユーザーがキーワードを入力
• 指定した列からキーワードを検索
• 該当する行を別のシート（または指定した範囲）にコピー
• 既存のデータを消さずに追記可能

---

VBAマクロ：キーワードを含む行を抽出・コピー

Sub ExtractRowsByKeyword()
    Dim wsSource As Worksheet, wsDest As Worksheet
    Dim lastRow As Long, destRow As Long
    Dim searchColumn As String, keyword As String
    Dim cell As Range
    
    ' 元データのシート（現在のアクティブシート）
    Set wsSource = ActiveSheet
    
    ' 結果を出力する新しいシートを作成
    On Error Resume Next
    Set wsDest = Worksheets("抽出結果")
    If wsDest Is Nothing Then
        Set wsDest = Worksheets.Add
        wsDest.Name = "抽出結果"
    End If
    On Error GoTo 0
    
    ' 抽出結果シートのデータをクリア
    wsDest.Cells.Clear
    
    ' 検索対象の列（手入力）
    searchColumn = "E" ' 例: "E" 列（区分）
    
    ' キーワード入力（メッセージボックスで入力）
    keyword = InputBox("抽出したいキーワードを入力してください", "キーワード検索")
    
    If keyword = "" Then
        MsgBox "キーワードが入力されていません。処理を終了します。", vbExclamation
        Exit Sub
    End If
    
    ' 元データの最終行を取得
    lastRow = wsSource.Cells(wsSource.Rows.Count, searchColumn).End(xlUp).Row
    
    ' ヘッダーをコピー
    wsSource.Rows(2).Copy Destination:=wsDest.Rows(2)
    
    ' 抽出結果の書き込み開始行
    destRow = 3
    
    ' 検索して一致する行をコピー
    For Each cell In wsSource.Range(searchColumn & "3:" & searchColumn & lastRow)
        If InStr(1, cell.Value, keyword, vbTextCompare) > 0 Then
            cell.EntireRow.Copy Destination:=wsDest.Rows(destRow)
            destRow = destRow + 1
        End If
    Next cell
    
    ' 抽出された行がない場合
    If destRow = 3 Then
        MsgBox "指定したキーワードに一致するデータはありませんでした。", vbInformation
    Else
        MsgBox "キーワード [" & keyword & "] を含む行を抽出しました！", vbInformation
        wsDest.Activate
    End If
End Sub

---

このマクロのポイント

✔ ユーザーがキーワードを入力（InputBox）
✔ E列（区分）を検索し、一致する行を抽出（E列以外の列も設定可能）
✔ 該当する行を「抽出結果」シートにコピー（新規作成 or 既存シート）
✔ データがない場合のエラーハンドリングも実装

---

使い方

1. マクロを実行（ExtractRowsByKeyword を実行）
2. キーワードを入力（例：「構造材」や「羽柄材」）
3. 一致する行が「抽出結果」シートにコピーされる！

---

改良版：キーワード検索の列もユーザーが選択可能

Sub ExtractRowsByKeyword()
    Dim wsSource As Worksheet, wsDest As Worksheet
    Dim lastRow As Long, destRow As Long
    Dim searchColumn As String, keyword As String
    Dim cell As Range
    
    ' 元データのシート（現在のアクティブシート）
    Set wsSource = ActiveSheet
    
    ' 結果を出力する新しいシートを作成
    On Error Resume Next
    Set wsDest = Worksheets("抽出結果")
    If wsDest Is Nothing Then
        Set wsDest = Worksheets.Add
        wsDest.Name = "抽出結果"
    End If
    On Error GoTo 0
    
    ' 抽出結果シートのデータをクリア
    wsDest.Cells.Clear
    
    ' 検索対象の列（手入力）
    searchColumn = "E" ' 例: "E" 列（区分）
    
    ' キーワード入力（メッセージボックスで入力）
    keyword = InputBox("抽出したいキーワードを入力してください", "キーワード検索")
    
    If keyword = "" Then
        MsgBox "キーワードが入力されていません。処理を終了します。", vbExclamation
        Exit Sub
    End If
    
    ' 元データの最終行を取得
    lastRow = wsSource.Cells(wsSource.Rows.Count, searchColumn).End(xlUp).Row
    
    ' ヘッダーをコピー
    wsSource.Rows(2).Copy Destination:=wsDest.Rows(2)
    
    ' 抽出結果の書き込み開始行
    destRow = 3
    
    ' 検索して一致する行をコピー
    For Each cell In wsSource.Range(searchColumn & "3:" & searchColumn & lastRow)
        If InStr(1, cell.Value, keyword, vbTextCompare) > 0 Then
            cell.EntireRow.Copy Destination:=wsDest.Rows(destRow)
            destRow = destRow + 1
        End If
    Next cell
    
    ' 抽出された行がない場合
    If destRow = 3 Then
        MsgBox "指定したキーワードに一致するデータはありませんでした。", vbInformation
    Else
        MsgBox "キーワード [" & keyword & "] を含む行を抽出しました！", vbInformation
        wsDest.Activate
    End If
End Sub

---

改良ポイント

✔ 検索対象の列を「マウスで選択」できる
✔ 選択した列のデータを検索し、指定したキーワードを含む行を抽出
✔ コードを書き換えなくても、どの列でも検索可能！

---

使い方

1. マクロを実行
2. 検索対象の列を選択（マウスで1列選択する）
3. キーワードを入力（例：「構造材」や「大阪府」など）
4. 一致する行が「抽出結果」シートにコピーされる！

---

---

---

🔨 VBAマクロ：指定範囲の行をランダムに並び替える

Sub ShuffleRows()
    Dim ws As Worksheet
    Dim rng As Range, tempRange As Range
    Dim rowCount As Long, i As Long, j As Long
    Dim temp As Variant
    
    ' シートの指定（アクティブシート）
    Set ws = ActiveSheet
    
    ' 並び替える範囲を選択
    On Error Resume Next
    Set rng = Application.InputBox("ランダムに並び替えたい範囲（行単位）を選択してください", Type:=8)
    On Error GoTo 0
    
    ' 選択がない場合、終了
    If rng Is Nothing Then
        MsgBox "範囲が選択されていません。処理を終了します。", vbExclamation
        Exit Sub
    End If
    
    ' 行数を取得
    rowCount = rng.Rows.Count
    
    ' 行数が1行以下なら処理しない
    If rowCount < 2 Then
        MsgBox "2行以上の範囲を選択してください。", vbExclamation
        Exit Sub
    End If
    
    ' ランダムに並び替えるための配列を作成
    Dim indexArr As Variant
    ReDim indexArr(1 To rowCount)
    
    ' インデックス配列を初期化
    For i = 1 To rowCount
        indexArr(i) = i
    Next i
    
    ' インデックスをランダムに並び替え（Fisher-Yatesシャッフル）
    For i = rowCount To 2 Step -1
        j = Int(Rnd() * i) + 1
        temp = indexArr(i)
        indexArr(i) = indexArr(j)
        indexArr(j) = temp
    Next i
    
    ' 一時的な範囲を作成して並び替え
    Set tempRange = rng.Offset(, rng.Columns.Count).Resize(rowCount, 1)
    
    ' ランダムな順序で行をコピー
    For i = 1 To rowCount
        rng.Rows(indexArr(i)).Copy Destination:=tempRange.Rows(i)
    Next i
    
    ' コピーした内容を元の範囲に上書き
    rng.Value = tempRange.Value
    
    ' 一時的なデータを削除
    tempRange.Clear
    
    MsgBox "選択した範囲の行をランダムに並び替えました！", vbInformation
End Sub

---

このマクロのポイント

✔ ユーザーが並び替えたい範囲を選択できる
✔ Fisher-Yatesシャッフル（高速で公平なシャッフル）を使用
✔ 元の表を直接並び替える（コピー＆ペーストで再配置）
✔ エラーチェック機能あり（1行だけの選択などを防ぐ）

---

使い方

1. マクロを実行（ShuffleRows を実行）
2. 並び替えたい範囲を選択（例: B3:F15 のように行単位で選択）
3. OKを押すと、その範囲の行がランダムに並び替えられる！

---

修正点 ✅ コピーではなく「元の位置を直接入れ替える」方法に変更
✅ 書式や値の保持を改善
✅ 範囲を正しく入れ替えるように修正

---

修正版：指定範囲の行をランダムに並び替える

Sub ShuffleRowsFixed()
    Dim ws As Worksheet
    Dim rng As Range
    Dim rowCount As Long, i As Long, j As Long
    Dim temp As Variant
    Dim indexArr As Variant
    
    ' アクティブシートを設定
    Set ws = ActiveSheet
    
    ' 並び替える範囲を選択
    On Error Resume Next
    Set rng = Application.InputBox("ランダムに並び替えたい範囲（行単位）を選択してください", Type:=8)
    On Error GoTo 0
    
    ' 範囲が選択されていない場合、終了
    If rng Is Nothing Then
        MsgBox "範囲が選択されていません。処理を終了します。", vbExclamation
        Exit Sub
    End If
    
    ' 行数を取得
    rowCount = rng.Rows.Count
    
    ' 2行以上の範囲が必要
    If rowCount < 2 Then
        MsgBox "2行以上の範囲を選択してください。", vbExclamation
        Exit Sub
    End If
    
    ' インデックス配列を作成（1から行数までの連番）
    ReDim indexArr(1 To rowCount)
    For i = 1 To rowCount
        indexArr(i) = i
    Next i
    
    ' インデックスをランダムに並び替え（Fisher-Yatesシャッフル）
    For i = rowCount To 2 Step -1
        j = Int(Rnd() * i) + 1
        temp = indexArr(i)
        indexArr(i) = indexArr(j)
        indexArr(j) = temp
    Next i
    
    ' シャッフルされた順序で行を直接入れ替える
    Dim tempRow As Variant
    For i = 1 To rowCount
        If i <> indexArr(i) Then
            tempRow = rng.Rows(i).Value
            rng.Rows(i).Value = rng.Rows(indexArr(i)).Value
            rng.Rows(indexArr(i)).Value = tempRow
        End If
    Next i
    
    MsgBox "選択した範囲の行をランダムに並び替えました！", vbInformation
End Sub

---

修正ポイント

✅ 「コピー」ではなく、直接入れ替える方式に変更
✅ データが別の場所にコピーされる問題を解消
✅ シャッフルロジックを修正し、全体のデータを乱れなく維持
✅ 日付や書式が崩れないように入れ替え

---

使い方

1. マクロを実行（ShuffleRowsFixed を実行）
2. 並び替えたい範囲を選択（例: A3:F15 のように行単位で選択）
3. OKを押すと、その範囲の行がランダムに並び替えられる！

---

---

🔨 修正版：罫線・計算式を維持し、値・色をシャッフルする

Sub ShuffleRowsWithFormatting()
    Dim ws As Worksheet
    Dim rng As Range
    Dim rowCount As Long, i As Long, j As Long
    Dim tempValue As Variant, tempInterior As Variant, tempFont As Variant
    Dim indexArr As Variant
    
    ' アクティブシートを設定
    Set ws = ActiveSheet
    
    ' 並び替える範囲を選択
    On Error Resume Next
    Set rng = Application.InputBox("ランダムに並び替えたい範囲（行単位）を選択してください", Type:=8)
    On Error GoTo 0
    
    ' 範囲が選択されていない場合、終了
    If rng Is Nothing Then
        MsgBox "範囲が選択されていません。処理を終了します。", vbExclamation
        Exit Sub
    End If
    
    ' 行数を取得
    rowCount = rng.Rows.Count
    
    ' 2行以上の範囲が必要
    If rowCount < 2 Then
        MsgBox "2行以上の範囲を選択してください。", vbExclamation
        Exit Sub
    End If
    
    ' インデックス配列を作成（1から行数までの連番）
    ReDim indexArr(1 To rowCount)
    For i = 1 To rowCount
        indexArr(i) = i
    Next i
    
    ' インデックスをランダムに並び替え（Fisher-Yatesシャッフル）
    For i = rowCount To 2 Step -1
        j = Int(Rnd() * i) + 1
        tempValue = indexArr(i)
        indexArr(i) = indexArr(j)
        indexArr(j) = tempValue
    Next i
    
    ' シャッフルされた順序で行を直接入れ替える（値・背景色・フォントカラー）
    Dim tempArr As Variant
    For i = 1 To rowCount
        If i <> indexArr(i) Then
            ' 値を一時保存
            tempArr = rng.Rows(i).Value
            rng.Rows(i).Value = rng.Rows(indexArr(i)).Value
            rng.Rows(indexArr(i)).Value = tempArr
            
            ' 書式の入れ替え（背景色・フォントカラー）
            For j = 1 To rng.Columns.Count
                tempInterior = rng.Cells(i, j).Interior.Color
                tempFont = rng.Cells(i, j).Font.Color
                
                rng.Cells(i, j).Interior.Color = rng.Cells(indexArr(i), j).Interior.Color
                rng.Cells(i, j).Font.Color = rng.Cells(indexArr(i), j).Font.Color
                
                rng.Cells(indexArr(i), j).Interior.Color = tempInterior
                rng.Cells(indexArr(i), j).Font.Color = tempFont
            Next j
        End If
    Next i
    
    MsgBox "選択した範囲の行を罫線・計算式を維持したままランダムに並び替えました！", vbInformation
End Sub

---

改善点

✅ 罫線・計算式を維持しつつ、値・背景色・フォントカラーを入れ替え
✅ 色ごとシャッフルすることで、違和感なく行が入れ替わる
✅ 列ごとではなく「行単位」でシャッフルするため、視認性を維持
✅ エラーハンドリング付きで、誤操作を防止

---

使い方

1. マクロを実行（ShuffleRowsWithFormatting を実行）
2. 並び替えたい範囲を選択（例: A3:F15 のように行単位で選択）
3. OKを押すと、罫線・計算式を維持したまま、値とセルの色がランダムに並び替わる！

---

---

---

🔨 VBAマクロ：選択範囲の重複データを一発削除

Sub RemoveDuplicates()
    Dim rng As Range
    Dim ws As Worksheet
    Dim colNum As Integer
    
    ' アクティブシートを設定
    Set ws = ActiveSheet
    
    ' 重複を削除する範囲を選択
    On Error Resume Next
    Set rng = Application.InputBox("重複削除を行う範囲を選択してください（タイトル行を含める）", Type:=8)
    On Error GoTo 0
    
    ' 選択範囲がない場合
    If rng Is Nothing Then
        MsgBox "範囲が選択されていません。処理を終了します。", vbExclamation
        Exit Sub
    End If
    
    ' ユーザーに重複削除の基準列を選択させる
    On Error Resume Next
    colNum = Application.InputBox("重複削除の基準にする列番号を入力してください（1列目なら1）", Type:=1)
    On Error GoTo 0
    
    ' 無効な入力チェック
    If colNum < 1 Or colNum > rng.Columns.Count Then
        MsgBox "正しい列番号を入力してください。", vbExclamation
        Exit Sub
    End If
    
    ' 重複削除の実行
    rng.RemoveDuplicates Columns:=colNum, Header:=xlYes
    
    MsgBox "重複データを削除しました！", vbInformation
End Sub

---

このマクロのポイント

✔ 選択した範囲の重複データを削除（タイトル行含める）
✔ 基準にする列をユーザーが選べる
✔ ワンクリックで実行可能（シンプルな操作）
✔ ヘッダーを考慮して重複判定する

---

使い方

1. マクロを実行（RemoveDuplicates を実行）
2. 重複チェックする範囲を選択（例: B2:F20 など）
3. 基準となる列番号を入力（例: 工務店で判定なら2, 邸名なら3）
4. OKを押すと、一発で重複データが削除される！

---

---

🔨 VBAマクロ：バックアップ用フォルダに自動保存

Sub AutoBackup()
    Dim wb As Workbook
    Dim backupFolder As String
    Dim backupFile As String
    Dim timeStamp As String
    
    ' 現在のブックを取得
    Set wb = ThisWorkbook
    
    ' バックアップ用のフォルダをデスクトップに設定
    backupFolder = Environ("USERPROFILE") & "\Desktop\Excelバックアップ\"
    
    ' バックアップフォルダが存在しない場合は作成
    If Dir(backupFolder, vbDirectory) = "" Then
        MkDir backupFolder
    End If
    
    ' タイムスタンプ付きのバックアップファイル名（例: ファイル名_20250218_120500.xlsx）
    timeStamp = Format(Now, "yyyymmdd_HHMMSS")
    backupFile = backupFolder & wb.Name & "_" & timeStamp & ".xlsx"
    
    ' バックアップを保存
    wb.SaveCopyAs backupFile
    
    MsgBox "バックアップを作成しました！" & vbCrLf & "保存先: " & backupFile, vbInformation
End Sub

---

このマクロのポイント

✔ デスクトップに「Excelバックアップ」フォルダを作成し、そこにバックアップを保存
✔ 現在のブックのコピーを、日付＆時間つきのファイル名で保存
✔ 既存のファイルを上書きせず、履歴をどんどん残せる
✔ フォルダがなければ自動作成！

---

使い方

1. マクロを実行（AutoBackup を実行）
2. デスクトップに「Excelバックアップ」フォルダが作成される（初回のみ）
3. 「ブック名_20250218_120500.xlsx」みたいな名前でバックアップ保存！
4. 履歴が残るので、過去データの復元が可能！

---

応用編

💡 「上書き保存するたびに自動バックアップ」する方法
このマクロを 「Workbook_BeforeSave」 に組み込めば、手動で実行しなくても 保存するたびにバックアップ を自動で取れるようになる！

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Call AutoBackup
End Sub

👉 「ThisWorkbook」モジュール に追加すると、上書き保存のたびにバックアップが自動作成される！

---

🔨 今回作ったVBAマクロ一覧

✅ ① 選択範囲の入れ替え（罫線を除く） → 指定した2つの範囲のデータを入れ替え！
✅ ② 指定したキーワードを含む行を抽出・コピー → どの列でも検索できる柔軟な検索機能！
✅ ③ 指定範囲の行をランダムで並び替え → 罫線と計算式を維持しつつ、値と色を入れ替え！
✅ ④ 重複データを一発削除 → 好きな列を基準にして、一発で重複データを整理！
✅ ⑤ Excelデータを自動保存＆バックアップ → いざという時のために安心のバックアップ機能！

---

---

---

🔨 今回の記事を読んでくれた皆さんへ！

🔨 終わりに