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

'-------------------------------------------------------------------------
' 指定フォルダ内全ブックの指定シート指定列を削除する
'-------------------------------------------------------------------------
' ※ マクロを実行すると列を削除したファイルは元に戻せませんので
'    予め指定フォルダのバックアップを作成しておくことを推奨します
'［作成日］2024.11.20
' https://excel.syogyoumujou.com/vba/delete_specifiedcolumn.html
'-------------------------------------------------------------------------
Sub 指定フォルダ内全ブックの指定シート指定列を削除する()
    '--------------------------------
    ' 削除する列番号を設定
    '--------------------------------
    Dim varTargetColumn As Variant
    varTargetColumn = "A" ' A列を削除対象とする
                          '［削除対象列の指定］
                          '  ・N列を削除する場合   ：varTargetColumn = "N"
                          '  ・A列,C列,E列を削除する場合：varTargetColumn = Array("A", "C", "E")
    
    '--------------------------------
    ' （列削除対象のシート名を設定）
    '--------------------------------
    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 = deleteSpecifiedColumn(shtTarget, varTargetColumn)
                
                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(varTargetColumn) Then
                .Range("A1").Value = "削除対象列：" & Join$(varTargetColumn, ",")
            Else
                .Range("A1").Value = "削除対象列：" & varTargetColumn
            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_specifiedcolumn.html
'-------------------------------------------------------------------------
Sub アクティブブックの全シート指定列を削除する()
    '--------------------------------
    ' 削除する列番号を設定
    '--------------------------------
    Dim strNumberOfColumn As String
    strNumberOfColumn = InputBox("削除する列をアルファベットで指定してください" & vbLf & _
                                 "［指定例］N列を指定する場合：N" & vbLf & _
                                 "　　　　　A列とC列を指定する場合：A,C" & vbLf & _
                                 "［列削除対象シート］" & vbLf & _
                                 " " & ActiveWorkbook.Name & " の全シート")
    strNumberOfColumn = Replace$(strNumberOfColumn, " ", "", , , vbTextCompare)
    If strNumberOfColumn = "" Then Exit Sub
    
    Dim varTargetColumn As Variant
    If InStr(1, strNumberOfColumn, ",", vbTextCompare) = 0 Then
        varTargetColumn = strNumberOfColumn
    Else
        varTargetColumn = Split(strNumberOfColumn, ",", , 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 = deleteSpecifiedColumn(shtTarget, varTargetColumn)
        
        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 = "削除対象列：" & strNumberOfColumn
            .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   ：対象ワークシートオブジェクト
'   TargetColumn：削除対象の列番号
'                 列番号を1次元配列で指定すると複数列をまとめて削除
'［戻り値］
'   成功        ：空の文字列
'   失敗        ：エラーメッセージ
'［作成日］2024.11.20
' https://excel.syogyoumujou.com/vba/delete_specifiedrow.html
'-------------------------------------------------------------------------
Function deleteSpecifiedColumn(ByRef shtTarget As Worksheet, _
                               ByVal TargetColumn As Variant) As String
    '--------------------------------
    ' シートの保護確認
    '--------------------------------
    If shtTarget.ProtectContents Then
        deleteSpecifiedColumn = "シートが保護されています"
        Exit Function
    End If
    
    '--------------------------------
    ' 削除対象列を配列として設定する
    '--------------------------------
    If Not IsArray(TargetColumn) Then TargetColumn = Array(TargetColumn)
    
On Error Resume Next
    '--------------------------------
    ' 削除対象列の1行目セルを集合する
    '--------------------------------
    Dim var      As Variant
    Dim rngUnion As Range
    For Each var In TargetColumn
        If rngUnion Is Nothing Then
            Set rngUnion = shtTarget.Cells(1, var)
        Else
            Set rngUnion = Union(rngUnion, shtTarget.Cells(1, var))
        End If
    Next
    If rngUnion Is Nothing Then
        deleteSpecifiedColumn = "指定した列番号が適切ではありません"
        Exit Function
    End If
    Err.Clear
    
    '--------------------------------
    ' 集合したセルの列を削除する
    '--------------------------------
    rngUnion.EntireColumn.Delete

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