【備忘録】VBAマクロ自動化コード

業務で複数のエクセルファイルの文言修正や、抽出が必要になることがあったので自分用の備忘録として

Dim filepath As String, cnt As Long '変数の宣言
Const folderpath  As String = "対象のファイルが入ったフォルダのパス" '定数の宣言
Const マクロ用エクセル As String = "このVBAを開いてるエクセルのファイル名.xlsm"


'対象のセルに、列追加や背景色を変更して新しい文言を追加する処理
'※部分をコメントアウトするなどで調節可能
Sub 対象文言検索後文字列追加()
    filepath = Dir(folderpath & "*.*") 'dir関数でフォルダの中のファイル名を返します
    Do While filepath <> "" '変数に空白が入るまで処理を繰り返す
    Dim targetWorkbook As Workbook
    Set targetWorkbook = Workbooks.Open(folderpath & filepath)  'ワークブックを開いていく
'--------実行させたい処理---------
    Dim sheet As Worksheet
    Set sheet = targetWorkbook.Sheets("対象のシート名")
    Dim 検索対象 As Range

    Set 検索対象 = sheet.Cells.Find("検索したい文言")
    If Not 検索対象 Is Nothing Then
        検索対象.Offset(0, 1).EntireColumn.Insert '右に列を１行追加
        検索対象.Offset(0, 1).Font.ColorIndex = 3　'文字を赤に指定
        検索対象.Offset(0, 1).Interior.Color = vbYellow　'背景色を黄色に指定
        検索対象.Offset(0, 1).Value = "挿入したい単語"　'
    End If

'--------実行させたい処理---------
    Workbooks(filepath).Close SaveChanges:=True
    '変数にまだ入力されていないファイル名を格納する
    filepath = Dir()
    Loop 'Do While に戻る
End Sub


'対象の文言を変更したい場合の処理
Sub 用語変更()
    filepath = Dir(folderpath & "*.*") 'dir関数でフォルダの中のファイル名を返します
    Do While filepath <> "" '変数に空白が入るまで処理を繰り返す
    Dim targetWorkbook As Workbook
    Set targetWorkbook = Workbooks.Open(folderpath & filepath)  'ワークブックを開いていく
'--------実行させたい処理---------
    Dim sheet As Worksheet
    Set sheet = targetWorkbook.Sheets("対象のシート名")
    Dim 変更前文言 As String
　Dim 変更後文言 As String
　変更後文言 = "変更したい文言"
    変更前文言 = "変更前文言"
    
    If Not sheet.Cells.Find(変更前文言) Is Nothing Then
        sheet.Cells.Find(変更前文言).Value = 変更後文言
    End If
    
    
    Workbooks(filepath).Close SaveChanges:=True
    'Workbooks(filepath).Save
    '変数にまだ入力されていないファイル名を格納する
    filepath = Dir()
    Loop 'Do While に戻る
End Sub


'対象の単語が存在するファイルの場合ファイル名を左側に、なければ右側に出力される処理

Sub 特定単語が存在するか確認()
    filepath = Dir(folderpath & "*.*")
    Dim Aindex As Integer
    Dim Bindex As Integer
    Aindex = 0
    Bindex = 0
    Do While filepath <> ""
    
    Dim targetWorkbook As Workbook
    Dim sheet As Worksheet
    Set targetWorkbook = Workbooks.Open(folderpath & filepath)  'ワークブックを開いていく
    Set sheet = targetWorkbook.Sheets("対象のシート名")
    
    If Not sheet Is Nothing Then
        If Not sheet.Cells.Find("対象の単語") Is Nothing Then
            Aindex = Aindex + 1
            Call 単語記載(filepath, Aindex, 1)
        Else
            Bindex = Bindex + 1
            Call 単語記載(filepath, Bindex, 2)
        End If
    Else
        Bindex = Bindex + 1
        Call 単語記載(filepath, Bindex, 2)
    End If
    
    Workbooks(filepath).Close SaveChanges:=False
    filepath = Dir()
    Loop
End Sub


Function 単語記載(words As String, ロウ As Integer, カラム As Integer)
    Dim マクロ用エクセル As Sheets
    Dim a As Workbook
    Dim sheet As Worksheet
    Set sheet = Workbooks("マクロ用エクセル").Sheets("抽出したい単語を記載したいシート名")
    sheet.Cells(ロウ, カラム).Value = words
End Function