HOME > エクセルVBA > サンプル > ReplaceList

ReplaceList


【ファイル名】ReplaceList.xlsm
【バージョン】Ver 1.0.0.0
【作成日】2019年08月27日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】ReplaceList.zip
【説明】「データ」シートのセルの値を「置換の一覧」シートの選択したセルで置換します。(数式は置換しません)

メニュー

操作

  1. 「データ」シートにデータを貼り付けます。
  2. 「置換の一覧」シートに1列目に検索する文字列を、2列目に置換え後の文字列を入力します。
  3.  置換え後の文字列を省略した場合は、検索する文字列を削除します。
     上の行から置換をします。
  4. 「置換の一覧」シートの連続する検索と置換のセルを選択します。
  5. 「サンプル」タブの置換のオプションを選択します。
  6. 「サンプル」タブの「すべて置換」ボタンを実行します。
注意 実行すると「検索と置換」のダイアログのオプションが変わります。

customUI14.xml
<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="onLoad">
  <ribbon startFromScratch="false">
    <tabs>
      <tab id="tab1" label="サンプル" keytip="S" insertBeforeMso="TabHome">
        <group id="group1" label="置換" keytip="A">
          <box id="box1" boxStyle="vertical">
            <checkBox id="MatchCaseCheckBox" label="大文字と小文字を区別する" keytip="C"  supertip="チェックすると大文字と小文字を区別します。" onAction="checkBox_onAction" getPressed="getPressed" />
            <checkBox id="LookAtCheckBox" label="セル内容が完全に同一であるものを検索する" keytip="O" supertip="チェックするとセル内容が完全に同一であるものを検索します。" onAction="checkBox_onAction" getPressed="getPressed" />
            <checkBox id="MatchByteCheckBox" label="半角と全角を区別する" keytip="B" supertip="チェックすると半角と全角を区別します。" onAction="checkBox_onAction" getPressed="getPressed" />
          </box>
          <box id="box2" boxStyle="vertical">
            <button idMso="SelectCurrentRegion" />
            <button id="ReplaceButton" label="すべて置換" supertip="「置換の一覧」シートの選択したセルの検索する文字列から「データ」シートを置換します。" imageMso="ReplaceDialog" onAction="onAction" />
          </box>
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
このページの上

Module1
Option Explicit

Private rbRibbon As IRibbonUI ' リボン
Private rbMatchCaseCheckBox As Boolean ' チェック
Private rbLookAtCheckBox As Boolean ' チェック
Private rbMatchByteCheckBox As Boolean ' チェック

Sub onLoad(ribbon As IRibbonUI) ' リボンの初期処理
  rbMatchCaseCheckBox = False
  rbLookAtCheckBox = False
  rbMatchByteCheckBox = False
  Set rbRibbon = ribbon ' リボンの表示を更新できるようにするためにリボンをセットする
  rbRibbon.Invalidate ' リボンの表示を更新する
End Sub

Sub getPressed(control As IRibbonControl, ByRef returnedVal) ' チェックボックスにチェックを設定する
  Select Case control.ID
    Case "MatchCaseCheckBox"
      returnedVal = rbMatchCaseCheckBox
    Case "LookAtCheckBox"
      returnedVal = rbLookAtCheckBox
    Case "MatchByteCheckBox"
      returnedVal = rbMatchByteCheckBox
  End Select
End Sub

Sub checkBox_onAction(control As IRibbonControl, pressed As Boolean) ' チェックボックスのクリック処理
  Select Case control.ID
    Case "MatchCaseCheckBox"
      rbMatchCaseCheckBox = pressed
    Case "LookAtCheckBox"
      rbLookAtCheckBox = pressed
    Case "MatchByteCheckBox"
      rbMatchByteCheckBox = pressed
  End Select
End Sub

Sub onAction(control As IRibbonControl) ' ボタンのクリック処理
  Select Case control.ID
    Case "ReplaceButton"
      Call Replace_Text
    Case Else
      MsgBox Prompt:="ボタンのクリックの処理がありません!", Buttons:=vbCritical, Title:="エラー"
  End Select
End Sub

Sub Replace_Text() ' 置換
  Dim dws As Worksheet
  Dim lws As Worksheet
  Dim rng As Range
  Dim i As Long
  
  On Error Resume Next
  Set dws = ThisWorkbook.Worksheets("データ")
  If Err.Number > 0 Then
    MsgBox Prompt:="「データ」の名前のワークシートが見つかりません!", Buttons:=vbCritical, Title:="エラー"
    Exit Sub
  End If
  
  If IsEmpty(dws.UsedRange) Then
    dws.Select
    MsgBox Prompt:="「データ」のワークシートが空です!", Buttons:=vbCritical, Title:="エラー"
    Exit Sub
  End If
  
  Set lws = ThisWorkbook.Worksheets("置換の一覧")
  If Err.Number <> 0 Then
    MsgBox Prompt:="「置換の一覧」の名前のワークシートが見つかりません!", Buttons:=vbCritical, Title:="エラー"
    Exit Sub
  End If
  
  lws.Select
  If ActiveWindow.RangeSelection.Areas(1).Cells.Count < 2 Then
    MsgBox Prompt:="「置換の一覧」のワークシートのセルが選択されていません!", Buttons:=vbCritical, Title:="エラー"
    Exit Sub
  End If
  
  For i = 1 To ActiveWindow.RangeSelection.Areas.Count
    If ActiveWindow.RangeSelection.Areas(i).Columns.Count < 2 Then
      MsgBox Prompt:="「置換の一覧」のワークシートで2列以上のセルが選択されていません!", Buttons:=vbCritical, Title:="エラー"
      Exit Sub
    End If
  Next
  
  Set rng = ActiveWindow.RangeSelection
''  Set rng = ActiveWindow.RangeSelection.Areas(1)
  dws.Select
  dws.Range("A1").Select
  
  Dim IsDisplayStatusbar As Boolean ' ステータスバーの表示状態を保存
  Dim tmpCalculation As XlCalculation ' 計算方法のモード
  Dim IsDisplayPageBreaks As Boolean  ' 改ページの有効・無効
  
  Application.EnableEvents = False ' イベントを無効にします。
  If Not Application.ActiveCell Is Nothing Then
    tmpCalculation = Application.Calculation ' 計算方法のモードを保存
    Application.Calculation = xlCalculationManual ' 計算方法のモードを手動にし、計算しない
  End If
  Application.EnableCancelKey = xlErrorHandler ' ◆ Esc キーを押すとエラーにします。
  IsDisplayStatusbar = Application.DisplayStatusBar ' ステータスバーの表示状態を保存
  Application.StatusBar = "実行中です。しばらくお待ちください...(中止は ESC キー)" ' ステータスバーにメッセージを表示
  Application.DisplayStatusBar = True ' ステータスバーを表示
  Application.Cursor = xlWait ' マウスカーソルを砂時計
  If Not Application.ActiveCell Is Nothing Then
    IsDisplayPageBreaks = ActiveSheet.DisplayPageBreaks ' 改ページの有効・無効を保存します。
    ActiveSheet.DisplayPageBreaks = False ' 改ページを無効にします。
  End If
  Application.ScreenUpdating = False '画面の更新を停止して、ちらつきを防止(ステータスバーのメッセージは更新できます)
  On Error GoTo ErrorHandle
  
  Dim LookAt As XlLookAt
  If rbLookAtCheckBox Then
    LookAt = xlWhole
  Else
    LookAt = xlPart
  End If
  
  Dim a As Long
  Dim r As Long
  Dim FindText As String
  Dim ReplaceText As String
  
  For a = 1 To rng.Areas.Count
    With rng.Areas(a)
      For r = 1 To .Rows.CountLarge
        If .Columns.Count > 1 Then ' 1列の場合は置換をしない
          FindText = .Cells(r, 1).Value
          ReplaceText = .Cells(r, 2).Value
          If Len(FindText) > 0 Then ' 検索文字がある場合のみ実行する
            dws.UsedRange.Replace What:=FindText, Replacement:=ReplaceText, LookAt:=LookAt, MatchCase:=rbMatchCaseCheckBox, MatchByte:=rbMatchByteCheckBox
          End If
        End If
      Next
    End With
  Next
  
'LookAt オプション バリアント型 (Variant) 使用できる定数は、XlLookAt クラスの xlWhole または xlPart です。
'MatchCase オプション バリアント型 (Variant) 大文字と小文字を区別して検索するには、True を指定します。
'MatchByte オプション バリアント型 (Variant) この引数は、Excel で 2 バイト (全角) 文字の言語サポートが選択またはインストールされている場合にだけ使用できます。2 バイト文字が 2 バイト文字とだけ一致するようにする場合は、True を指定します。2 バイト文字が 2 バイト文字だけではなく、対応する 1 バイト文字とも一致するようにする場合は False を指定します。
' <--------------------------------------------------------------------------------------------------------------------------
ErrorHandle: ' ◆ 元に戻す処理 (エラーや、[Ctrl+Break]キーが押された場合のため)
  Application.ScreenUpdating = True '画面を更新します。
  
  If Err.Number > 0 Then ' エラー処理
    MsgBox Prompt:="エラー番号:" & Err.Number & vbNewLine & Err.Description, Buttons:=vbCritical, Title:="エラー"
  End If
  
  Application.EnableEvents = True ' イベントを有効にします。
  If Not Application.ActiveCell Is Nothing Then
    Application.Calculation = tmpCalculation ' 計算方法のモードを元に戻します。
  End If
  Application.StatusBar = "" ' ステータスバーの文字列をクリアーします。
  Application.DisplayStatusBar = IsDisplayStatusbar ' ステータスバーの表示を元に戻します。
  Application.Cursor = xlDefault ' マウスカーソルを省略値に戻します。
  Application.EnableCancelKey = xlInterrupt ' デバッグ、終了などを行えるように、実行中のプロシージャを停止します。
  If Not Application.ActiveCell Is Nothing Then ActiveSheet.DisplayPageBreaks = IsDisplayPageBreaks ' 改ページを元に戻します。
  Application.DisplayAlerts = True ' 確認メッセージを表示します。
End Sub

Sub Clear_Data_Cell() ' 「データ」のシートのクリアー
  ThisWorkbook.Worksheets("データ").UsedRange.Delete
  ThisWorkbook.Worksheets("データ").Range("A1").Select
End Sub
このページの上