タイトル列を検索して指定した列を残す

2024.06.23

タイトル列を検索して、指定したタイトルと一致した列は削除しません。残ることになります。
カンマ区切りで複数タイトルを指定できます。

残すのと反対に、タイトル列を検索して指定した列を消す 処理もあります。

【例】
処理パラメータ

タイトルのA1を空欄にしているため、「LeaveSpecifiedTitle ws, title 2」と引数3を2にすることで、B1から検索を開始するようになります。A1が空欄の場合は引数3は不要です。

以下の関数を使用していますので、リンクから関数をコピーします。
・ファイルの有無を確認する IsFileExists()
・最終列を取得(最右端から) GetLastColumn()
・ナンバリングしたファイル名を作成する FilenameAddNumber()

【サンプルプログラム】

Sub TitleDelete()
    Dim title As Variant
    Dim filename As String
    Dim new_filename As String
    Dim wb As Workbook
    Dim ws As Worksheet
   
    ' 消したいタイトルを取得（カンマ区切りで分割）
    title = Split(Range("B2"), ",")
    filename = Range("B1")

    ' ファイルの確認
    If IsFileExists(filename) = True Then
        ' ブックを開く
        Set wb = Workbooks.Open(filename)
        ' シートを取得
        Set ws = wb.Sheets(1)

        ' タイトルを検索してその列を残す
        LeaveSpecifiedTitle ws, title, 2

        ' ファイルは上書きしないように、新しいファイルを作成
        new_filename = FilenameAddNumber(filename)
        
        wb.SaveAs filename:=new_filename
        wb.Close
        
    Else
        MsgBox filename & "は存在しません", vbExclamation
    End If
End Sub

元ファイルが上書き保存されてしまうことを防止するため、新しいファイルを作成しています。
不要な場合は、保存の部分を以下のように修正してください。

        ' ファイルは上書きしないように、新しいファイルを作成
        new_filename = FilenameAddNumber(filename)
        
        wb.SaveAs filename:=filename

【関数化】

' ------------------------------------------------------------
' 説明：タイトル列を検索して指定した列を残す
' 引数：1:処理対象のワークシート
'       2:残したい列のタイトル名(一致するタイトルを記載)
'       3:一致するか確認する列の開始位置 省略時は1(A列から)
' 戻値：-
' 備考：指定したワークシートに対して処理を行う
'       列のタイトル名を複数指定する場合は、「,」で区切りスペースなど入れない
'       例：xxx,yyy,zzz
' ------------------------------------------------------------
Sub LeaveSpecifiedTitle(ws As Worksheet, title As Variant, Optional ByVal start As Long = 1)
    Dim max_column As Long
    Dim idx1 As Long
    Dim idx2 As Long
    Dim flg As Integer

    ' 最大列を取得
    max_column = GetLastColumn(ws)

    ' 列の開始位置を
    If start < 1 Then
        start = 1
    End If

    ' 列の開始位置を決める
    idx1 = start
    
    ' 列数でループする
    While idx1 <= max_column
        ' 判定用のフラグを初期化
        flg = 0
        
        ' 残すタイトルに一致するかを確認
        For idx2 = LBound(title) To UBound(title)
            DoEvents
        
            If ws.Cells(1, idx1) = title(idx2) Then
                ' タイトルと一致したら消さない
                flg = 1
                Exit For
            End If
        Next idx2
        
        ' 一致するものが無かったので削除
        If flg = 0 Then
            ws.Columns(idx1).Delete
            ' トータルの件数を減らす
            ' カウントアップしないので、削除して詰まった列を確認する
            max_column = max_column - 1
        Else
            ' カウントアップ
            idx1 = idx1 + 1
        End If
    Wend
End Sub

【修正】
関数化の箇所でファイル読み込み処理を行っていたが、汎用性を高めるため関数外としました

コメント