トップ　>　汎用コード　>　指定フォルダ全ブックの指定シート指定行を一括削除

'-------------------------------------------------------------------------
' 指定フォルダ内全ブックの指定シート指定行を削除する
'-------------------------------------------------------------------------
' ※ マクロを実行すると行を削除したファイルは元に戻せませんので
'    予め指定フォルダのバックアップを作成しておくことを推奨します
'［作成日］2024.11.20
' https://excel.syogyoumujou.com/vba/delete_specifiedrow.html
'-------------------------------------------------------------------------
Sub 指定フォルダ内全ブックの指定シート指定行を削除する()
    '--------------------------------
    ' 削除する行番号を設定
    '--------------------------------
    Dim varTargetRow As Variant
    varTargetRow = 3      ' 3行を削除対象とする
                          '［削除対象行の指定］
                          '  ・10行を削除する場合       ：varTargetRow = 10
                          '  ・1行,3行,5行を削除する場合：varTargetRow = Array(1, 3, 5)
    
    '--------------------------------
    ' （行削除対象のシート名を設定）
    '--------------------------------
    Dim strTargetSheetName As String
    strTargetSheetName = "" ' 行削除対象を全シートとする
                            '［シート名の指定］
                            '  ・全シートを対象とする場合：strTargetSheetName = ""
                            '  ・「Sheet1」シートを対象とする場合：strTargetSheetName = "Sheet1"

    '--------------------------------
    ' フォルダの選択
    '--------------------------------
    Dim strFolderPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then strFolderPath = .SelectedItems(1)
    End With
    If Len(strFolderPath) = 0 Then Exit Sub

    '--------------------------------
    ' フォルダの存在確認
    '--------------------------------
    If Dir(strFolderPath, vbDirectory) = "" Then
        MsgBox "対象のフォルダが見つかりません", vbExclamation, "終了します"
        Exit Sub
    End If
    
    '--------------------------------
    ' 処理実行確認
    '--------------------------------
    If MsgBox("処理を実行しますか？", vbYesNo, Dir(strFolderPath, vbDirectory)) = vbNo Then Exit Sub
    
    '--------------------------------
    ' フォルダ内ブックを検索
    '--------------------------------
    Dim strFileName As String
    strFolderPath = strFolderPath & Application.PathSeparator ' フォルダパスに区切り文字追加
    strFileName = Dir(strFolderPath & "*.xls?")               ' フォルダからExcelブックを検索
    If strFileName = "" Then                                  ' ブックのパスを取得できなければ終了
        MsgBox "指定フォルダ内にExcelブックが見つかりません", vbExclamation, "終了します"
        Exit Sub
    End If
    
On Error Resume Next
    '--------------------------------
    ' ブックを順に開き処理を実行
    '--------------------------------
    Application.ScreenUpdating = False  ' 画面更新無効
    Application.EnableEvents = False    ' イベント無効
    
    Dim appExcel    As Excel.Application
    Dim bokTarget   As Workbook
    Dim shtTarget   As Worksheet
    Dim strMessage  As String
    Dim lngCount    As Long
    Dim strResult() As String
    Do
        ' フォルダ内のブックを開く
        Set appExcel = Excel.Application
        Set bokTarget = appExcel.Workbooks.Open(strFolderPath & strFileName)
        
        'ブックの各シートの対象行削除
        For Each shtTarget In bokTarget.Worksheets
            If strTargetSheetName = "" Or strTargetSheetName = shtTarget.Name Then
            
                ' 指定シートの指定行を削除する
                strMessage = deleteSpecifiedRow(shtTarget, varTargetRow)
                
                If strMessage = "" Then strMessage = "削除成功"
                
                ' 結果を配行変数に追加する
                ReDim Preserve strResult(lngCount)
                strResult(lngCount) = "ブック名：" & bokTarget.Name & _
                                      "　シート名：" & shtTarget.Name & "　" & strMessage
                lngCount = lngCount + 1
            End If
        Next
        
        ' 対象ブックを保存して閉じる
        bokTarget.Save
        bokTarget.Close
        
        Set bokTarget = Nothing
        Set appExcel = Nothing
        
        ' 次のExcelブックを検索
        strFileName = Dir()
    Loop Until strFileName = "" ' ブックが見つからなければループから抜ける
    
    strFileName = Dir("")

    '--------------------------------
    ' 結果出力
    '--------------------------------
    If lngCount = 0 Then
        MsgBox "削除対象のシートが見つかりませんでした", vbInformation
    Else
        MsgBox "実行結果を出力します", vbInformation
        With Workbooks.Add.Worksheets(1)
            If IsArray(varTargetRow) Then
                .Range("A1").Value = "削除対象行：" & Join$(varTargetRow, ",")
            Else
                .Range("A1").Value = "削除対象行：" & varTargetRow
            End If
            .Range("A2").Resize(lngCount, 1).Value = WorksheetFunction.Transpose(strResult)
        End With
        ActiveWindow.WindowState = xlNormal
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
On Error GoTo 0
End Sub

'-------------------------------------------------------------------------
' アクティブブックの全シート指定行を削除する
'-------------------------------------------------------------------------
'［作成日］2024.11.20
' https://excel.syogyoumujou.com/vba/delete_specifiedrow.html
'-------------------------------------------------------------------------
Sub アクティブブックの全シート指定行を削除する()
    '--------------------------------
    ' 削除する行番号を設定
    '--------------------------------
    Dim strNumberOfRow As String
    strNumberOfRow = InputBox("削除する行をアルファベットで指定してください" & vbLf & _
                              "［指定例］10行を指定する場合：10" & vbLf & _
                              "　　　　　1行と3行を指定する場合：1,3" & vbLf & _
                              "［行削除対象シート］" & vbLf & _
                              " " & ActiveWorkbook.Name & " の全シート")
    strNumberOfRow = Replace$(strNumberOfRow, " ", "", , , vbTextCompare)
    If strNumberOfRow = "" Then Exit Sub
    
    Dim varTargetRow As Variant
    If InStr(1, strNumberOfRow, ",", vbTextCompare) = 0 Then
        varTargetRow = strNumberOfRow
    Else
        varTargetRow = Split(strNumberOfRow, ",", , vbTextCompare)
    End If
    
On Error Resume Next
    '--------------------------------
    ' 処理実行
    '--------------------------------
    Application.ScreenUpdating = False  ' 画面更新無効
    Application.EnableEvents = False    ' イベント無効
    
    Dim shtTarget      As Worksheet
    Dim strMessage     As String
    Dim lngCount       As Long
    Dim strResult()    As String
    'アクティブブックの各シートの対象行削除
    For Each shtTarget In ActiveWorkbook.Worksheets
        
        ' 指定シートの指定行を削除する
        strMessage = deleteSpecifiedRow(shtTarget, varTargetRow)
        
        If strMessage = "" Then strMessage = "削除成功"
        
        ' 結果を配行変数に追加する
        ReDim Preserve strResult(lngCount)
        strResult(lngCount) = "シート名：" & shtTarget.Name & "　" & strMessage
        lngCount = lngCount + 1
    Next

    '--------------------------------
    ' 結果出力
    '--------------------------------
    If lngCount = 0 Then
        MsgBox "削除対象のシートが見つかりませんでした", vbInformation
    Else
        MsgBox "実行結果を出力します", vbInformation
        With Workbooks.Add.Worksheets(1)
            .Range("A1").Value = "削除対象行：" & strNumberOfRow
            .Range("A2").Resize(lngCount, 1).Value = WorksheetFunction.Transpose(strResult)
        End With
        ActiveWindow.WindowState = xlNormal
    End If

    Application.EnableEvents = True
    Application.ScreenUpdating = True
On Error GoTo 0
End Sub

'-------------------------------------------------------------------------
' 指定シートの指定行を削除する
'-------------------------------------------------------------------------
'［引数］
'   shtTarget：対象ワークシートオブジェクト
'   TargetRow：削除対象の行番号
'              行番号を1次元配行で指定すると複数行をまとめて削除
'［戻り値］
'   成功        ：空の文字行
'   失敗        ：エラーメッセージ
'［作成日］2024.11.20
' https://excel.syogyoumujou.com/vba/delete_specifiedrow.html
'-------------------------------------------------------------------------
Function deleteSpecifiedRow(ByRef shtTarget As Worksheet, _
                            ByVal TargetRow As Variant) As String
    '--------------------------------
    ' シートの保護確認
    '--------------------------------
    If shtTarget.ProtectContents Then
        deleteSpecifiedRow = "シートが保護されています"
        Exit Function
    End If
    
    '--------------------------------
    ' 削除対象行を配行として設定する
    '--------------------------------
    If Not IsArray(TargetRow) Then TargetRow = Array(TargetRow)
    
On Error Resume Next
    '--------------------------------
    ' 削除対象行のA列セルを集合する
    '--------------------------------
    Dim var      As Variant
    Dim rngUnion As Range
    For Each var In TargetRow
        If rngUnion Is Nothing Then
            Set rngUnion = shtTarget.Cells(var, "A")
        Else
            Set rngUnion = Union(rngUnion, shtTarget.Cells(var, "A"))
        End If
    Next
    If rngUnion Is Nothing Then
        deleteSpecifiedRow = "指定した行番号が適切ではありません"
        Exit Function
    End If
    Err.Clear
    
    '--------------------------------
    ' 集合したセルの行を削除する
    '--------------------------------
    rngUnion.EntireRow.Delete

On Error GoTo 0
    ' エラーの場合は戻り値にエラー情報を設定する
    If Err.Number <> 0 Then
        deleteSpecifiedRow = "エラー番号：" & Err.Number & vbLf & Err.Description
    End If
End Function