Excel VBA セル操作

Excel VBA のトップに戻る
Excel VBA 目次

Excelの最終行を取得
行列処理
　・同上の補完
　・変数を使って、セルを指定する方法
セル範囲を、配列に一括登録、およびその逆
行列入れ替えコピー
　・連立1次方程式の解
　・子供の血液型の出現率
Excel関数の VLOOKUP をマクロで
Excel関数の VLOOKUP をマクロで(セル置換)
選択範囲を取得し、A1形式で表示
セルのデータチェック
セルの文字検索と置換
セルデータの集計と文字検索
並び替え＋重複行削除

索引


Excel関数の VLOOKUP をマクロで

　Excel で、データ加工するとき、VLOOKUP を使う機会が有るでしょう。
　しかし、データ件数が多いときに VLOOKUP 関数を使うと、Excel ファイル・サイズが大きくなり、処理も重たくなります。

　ここでは、マクロを使って、データ参照更新できるようにしたものを、紹介します。
　コピー元のデータを、前もって配列に読み込んでおいて、メモリ上で照合することで、高速化を図っています。
　キーの照合は、「完全一致」だけでなく、「前方一致」と「部分一致」も、ボタンで使い分けられるようにしました。
　マクロ処理の中で、キーの並び替えを行っているで、Excelの VLOOKUP関数を使うときのように、「コピー元」の範囲のキーのデータを、事前に昇順に並べておく必要は、有りません。

　このマクロは、キーの列は、一つだけでなく、最大、3列の項目の文字列連結(RTrim)まで、対応しています。

　私は、業務で、日常的に、数千〜数万件のデータを扱うため、このマクロを重宝して活用しています。

このマクロをダウンロードできます。→VLookUpVBA11.xls更新

　マクロの使い方：
　「貼付け先」のブックの、対象シートから、指定された行(貼付先キー開始行)以下の「貼付け先参照キーの列」の最後のセルまでの範囲で、そのセルの値をキーとして、

　「コピー元」のブックの、対象シートから、指定された行(コピー元キー開始行)以下の範囲の、「コピー元参照キーの列」で上のキーの値を検索し、「コピー対象列」の同じ行にある値を、

　「貼付け先」のブックの、対象シートの、「貼付け先列」の該当行に貼り付けます。
　バージョン04で、対象の列は、8列まで同時にコピーできるようにしました。

　VLOOKUP 関数の "V" は、縦方向 (vertical) の検索を意味します。
　キーの照合では、英字の大文字と小文字は区別されません。


　事例のデータ・ブックのダウンロード：
「貼付け先」
WorkBook.xls
月名和名月
January
February
March
April
May
June
July
August
September
October
November
December
April
August
December
February
January
July
June
March
May
November
October
September
「コピー元」
Dictionary.xls
月和名英名1英名2
1睦月JaJan
2如月FFeb
3弥生MarMar
4卯月ApApr
5皐月MayMay
6水無月JunJun
7文月JulJul
8葉月AuAug
9長月SSep
10神無月OOct
11霜月NNov
12師走DDec

　左の WorkBook.xls の「月名」をキーに、
　右側の Dictionary.xls の「英名1」を前方一致で参照して、「和名」と「英名2」を見つけます。
　この「和名」と「英名2」を、左の WorkBook.xls に貼り付けます。


参照関係の読み込み


Option Explicit
Option Base 1

Public コピー元ブック名 As String
Public コピー元シート名 As String
Public コピー元参照キー列番号 As Integer
Public コピー対象列番号(8) As Integer
Public コピー元キー開始行 As Integer
Public 貼付け先ブック名 As String
Public 貼付け先シート名 As String
Public 貼付け先参照キー列番号 As Integer
Public 貼付け先対象列番号(8) As Integer
Public 貼付け先キー開始行 As Integer
Public コピー列数 As Integer
Public コピー元追加キー列数 As Integer
Public 貼付け先追加キー列数 As Integer
Public コピー元参照キー列番号配列() As Integer
Public 貼付け先参照キー列番号配列() As Integer


Sub 参照関係の読み込み()
   Dim キー列名 As String

    ThisWorkbook.Worksheets("Sheet1").Activate

    '★コピー元★
    
    If Range("B11").Value <> "" Then
        コピー元ブック名 = Range("B11").Value
    Else
        MsgBox "コピー元ブック名が、未登録です。"
        End
    End If
    
    If Range("C11").Value <> "" Then
        コピー元シート名 = Range("C11").Value
    Else
        MsgBox "コピー元ブック名が、未登録です。"
        End
    End If
    
    キー列名 = Trim(Range("D11").Value)
    If キー列名 <> "" Then

      If 検索したパターン数(キー列名, "&") = 0 Then 'キーの列名に & が含まれない
        コピー元参照キー列番号 = 列番号(キー列名)

      Else '列名の文字列に　& が含まれる
         コピー元参照キー列番号 = 列番号(Trim(Left(キー列名, InStr(キー列名, "&") - 1)))
         コピー元追加キー列数 = 検索したパターン数(キー列名, "&")
         ReDim コピー元参照キー列番号配列(コピー元追加キー列数)
         Select Case コピー元追加キー列数
            Case 1
               コピー元参照キー列番号配列(1) _
               = 列番号(Trim(Right(キー列名, Len(キー列名) - InStr(キー列名, "&"))))
            Case 2
               コピー元参照キー列番号配列(1) _
               = 列番号(Trim(Mid(キー列名, InStr(キー列名, "&") + 1, InStrRev(キー列名, "&") - InStr(キー列名, "&") - 1)))
               コピー元参照キー列番号配列(2) _
               = 列番号(Trim(Right(キー列名, Len(キー列名) - InStrRev(キー列名, "&"))))
            Case Else
               MsgBox "コピー元参照キーの列数が3以上です。"
               End
         End Select
      End If
    Else
        MsgBox "コピー元参照キー列番号が、未登録です。"
        End
    End If
    
    If Range("F11").Value <> "" Then
        コピー元キー開始行 = Range("F11").Value
    Else
        MsgBox "コピー元キー開始行が、未登録です。"
        End
    End If

    For コピー列数 = 1 To 8
        If Range("E11").Cells(コピー列数, 1).Value <> "" Then
            コピー対象列番号(コピー列数) = 列番号(Range("E11").Cells(コピー列数, 1).Value)
        Else
            Exit For
        End If
    Next コピー列数
   コピー列数 = コピー列数 - 1  'Next を通るとき、変数の値が、1過剰になるので戻す。


    '★貼付け先★
    
    If Range("B21").Value <> "" Then
        貼付け先ブック名 = Range("B21").Value
    Else
        MsgBox "貼付け先ブック名が、未登録です。"
        End
    End If
        
    If Range("C21").Value <> "" Then
        貼付け先シート名 = Range("C21").Value
    Else
        MsgBox "貼付け先シート名が、未登録です。"
        End
    End If
    
    キー列名 = Trim(Range("D21").Value)
    If キー列名 <> "" Then
      If 検索したパターン数(キー列名, "&") = 0 Then 'キーの列名に & が含まれない
        貼付け先参照キー列番号 = 列番号(キー列名)

      Else '列名の文字列に　& が含まれる
         貼付け先参照キー列番号 = 列番号(Trim(Left(キー列名, InStr(キー列名, "&") - 1)))
         貼付け先追加キー列数 = 検索したパターン数(キー列名, "&")
         ReDim 貼付け先参照キー列番号配列(貼付け先追加キー列数)
         Select Case 貼付け先追加キー列数
            Case 1
               貼付け先参照キー列番号配列(1) _
               = 列番号(Trim(Right(キー列名, Len(キー列名) - InStr(キー列名, "&"))))
            Case 2
               貼付け先参照キー列番号配列(1) _
               = 列番号(Trim(Mid(キー列名, InStr(キー列名, "&") + 1, InStrRev(キー列名, "&") - InStr(キー列名, "&") - 1)))
               貼付け先参照キー列番号配列(2) _
               = 列番号(Trim(Right(キー列名, Len(キー列名) - InStrRev(キー列名, "&"))))
            Case Else
               MsgBox "貼付け先参照キーの列数が3以上です。"
               End
         End Select
      End If

    Else
        MsgBox "貼付け先参照キー列名が、未登録です。"
        End
    End If
    
    If Range("F21").Value <> "" Then
        貼付け先キー開始行 = Range("F21").Value
    Else
        MsgBox "貼付け先キー開始行が、未登録です。"
        End
    End If
    
    For 行 = 1 To コピー列数
      If Range("E21").Cells(行, 1).Value <> "" Then
          貼付け先対象列番号(行) = 列番号(Range("E21").Cells(行, 1).Value)
      Else
          MsgBox "コピー元と貼付け先の列数が不一致です。重複登録してでも数を合せて下さい。"
          End
      End If
   Next 行

End Sub



'★検索した文字列パターン数(または文字数)をカウント★
Function 検索したパターン数(検索対象の文字列 As String, 検索する文字列 As String) As Integer
   If Len(検索する文字列) = 0 Then
      検索したパターン数 = 0
   Else
      検索したパターン数 = (Len(検索対象の文字列) _
      - Len(Replace(検索対象の文字列, 検索する文字列, "")))/Len(検索する文字列)
   End If
End Function

この種類の目次に戻る↑　索引へ↓　トップページに戻る

完全一致


Option Explicit
Option Base 1

Public 行 As Long
Public 列 As Integer
Public マスタ件数 As Long
Public 最終行 As Long
Public 検索行 As Long
Public 開始時刻 As Variant
Public 終了時刻 As Variant


Sub データコピー完全一致() '★完全★一致★
   Dim データ()
   Dim 参照キー As String '参照データを、数値と文字と読み違えると合致しないので
   Dim 追加キー数 As Integer
   
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual

   開始時刻 = Now()

   Call 参照関係の読み込み

    'マスタデータを配列に読み込む
        'マスタ側のブック名とマスタ側のテーブル名
    Workbooks(コピー元ブック名).Worksheets(コピー元シート名).Activate
    
    最終行 = Cells(ActiveSheet.Rows.Count, コピー元参照キー列番号).End(xlUp).Row
    マスタ件数 = 最終行 - コピー元キー開始行 + 1
    
    ReDim データ(マスタ件数, コピー列数 + 1)
    
    For 行 = コピー元キー開始行 To 最終行
         データ(行 - コピー元キー開始行 + 1, 1) _
         = Cells(行, コピー元参照キー列番号).Value 'ID 参照キー★★★

         If コピー元追加キー列数 > 0 Then
            For 追加キー数 = 1 To コピー元追加キー列数
               データ(行 - コピー元キー開始行 + 1, 1) = データ(行 - コピー元キー開始行 + 1, 1) _
               & CStr(Cells(行, コピー元参照キー列番号配列(追加キー数)).Value) 'ID 参照キーを文字として★
            Next 追加キー数
         End If

         For 列 = 1 To コピー列数
            データ(行 - コピー元キー開始行 + 1, 列 + 1) _
            = "'" & Cells(行, コピー対象列番号(列)).Value '登録データ ★★★
         Next 列
    Next 行
    
   Application.StatusBar = "☆ コピー元データを、読込み完了 ☆"

    'コピー貼付けする
        '登録側のブック名、とテーブル名
    Workbooks(貼付け先ブック名).Worksheets(貼付け先シート名).Activate
    
    最終行 = Cells(ActiveSheet.Rows.Count, 貼付け先参照キー列番号).End(xlUp).Row

    For 行 = 貼付け先キー開始行 To 最終行
      参照キー = Cells(行, 貼付け先参照キー列番号).Value
      
      If 貼付け先追加キー列数 > 0 Then
         For 追加キー数 = 1 To 貼付け先追加キー列数
            参照キー = 参照キー _
            & Cells(行, 貼付け先参照キー列番号配列(追加キー数)).Value 'ID 参照キーを文字として★
         Next 追加キー数
      End If

      For 検索行 = 1 To マスタ件数
         If 参照キー = データ(検索行, 1) Then 'ID 参照キー★★★
            For 列 = 1 To コピー列数
               If Cells(行, 貼付け先対象列番号(列)).Value = "" Then
                    Cells(行, 貼付け先対象列番号(列)).Value = データ(検索行, 列 + 1) '登録データ ★★★
                End If
            Next 列    '貼付先列の数だけ繰返し
            Exit For
        End If
      Next 検索行      '貼付け元のキーが有るだけ繰返し
      
      If (行 Mod 1000) = 0 Then
         Application.ScreenUpdating = True
        Application.StatusBar = "☆貼り付け先" & 行 & " 行目まで書き込み☆"
         Application.ScreenUpdating = False
      End If

   Next 行            '貼付先の行が有るだけ繰返し
    
   Application.StatusBar = False 'ステータスバーの表示をクリア
   Application.ScreenUpdating = True
   Application.Calculation = xlCalculationAutomatic

   終了時刻 = Now()
   MsgBox "処理が終了しました。" & Chr(13) & _
   "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly

End Sub

　解説：
　読み込んだセルの値の前に「'」を付けて、明示的に「文字属性」にしています。
　こうしておかないと、数字列で先頭に「0」が有る場合は、「0」が削除されてしまうからです。


　Application.StatusBar プロパティ は、ステータス バーの文字列を設定します。値の取得および設定が可能です。文字列型 (String) の値を使用します。
　Excel 側でステータス バーを制御しているとき、このプロパティは False を返します。ステータス バーの文字列を既定値に戻すには、プロパティに False を設定します。ステータス バーが非表示の状態でも、この設定によって文字列は既定値に戻ります。

　上の例では、コピー元行数と貼付け先行数の組合せ数が大きいと、それなりの時間がかかります。処理の進度状況を、ステータス・バーに表示して、分かりやすくしています。

　次の使用例は、Large.xls ブックを開く前に、ステータス バーの文字列を "しばらくお待ちください..." に設定し、その後既定の設定に戻します。 

oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.StatusBar = "しばらくお待ちください..."
Workbooks.Open filename:="LARGE.XLS"
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar

この種類の目次に戻る↑　索引へ↓　トップページに戻る

前方一致


Option Explicit
Option Base 1

Dim 行 As Integer
Dim マスタ件数 As Integer
Dim 最終行 As Integer
Dim 検索行 As Integer

Sub データコピー前方一致() '★★前方★★一致★★
Dim データ()

    Call 参照関係の読み込み

    'マスタデータを配列に読み込む
    Workbooks(コピー元ブック名).Worksheets(コピー元シート名).Activate
    
    最終行 = Cells(ActiveSheet.Rows.Count, コピー元参照キー列番号).End(xlUp).Row
    マスタ件数 = 最終行 - コピー元キー開始行 + 1
    
    ReDim データ(マスタ件数, 2)
    
    For 行 = コピー元キー開始行 To 最終行
        データ(行 - コピー元キー開始行 + 1, 1) _
        = Cells(行, コピー元参照キー列番号).Value 'ID 参照キー★★★
        データ(行 - コピー元キー開始行 + 1, 2) _
        = "'" & Cells(行, コピー対象列番号).Value '登録データ ★★★
    Next 行
    
    'キーの文字数の逆順に並び替える。
    '理由は、例えば、A、ABとあったとき、文字数の逆順にしておかないと、全てAで当たってしまうから。
    ThisWorkbook.Activate
    Worksheets.Add after:=Worksheets("Sheet1")
    ActiveSheet.Name = "ソートワーク"
    ThisWorkbook.Worksheets("ソートワーク").Range("A1").Resize(マスタ件数, 2).Value = データ
    
    For 行 = 1 To マスタ件数
        Range("C1").Cells(行, 1).Value = Len(Range("A1").Cells(行, 1).Value)
    Next 行
    
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Sort _
        Key1:=Range("C1"), _
        Order1:=xlDescending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlPinYin

    ReDim データ(マスタ件数, 2)
    
    データ = ThisWorkbook.Worksheets("ソートワーク").Range("A1").Resize(マスタ件数, 2).Value

    Application.DisplayAlerts = False
    ThisWorkbook.Worksheets("ソートワーク").Delete
    Application.DisplayAlerts = True
    
    'コピー貼付けする
    
    Workbooks(貼付け先ブック名).Worksheets(貼付け先シート名).Activate
    
    最終行 = Cells(ActiveSheet.Rows.Count, 貼付け先参照キー列番号).End(xlUp).Row
    For 行 = 貼付け先キー開始行 To 最終行
        If Cells(行, 貼付け先対象列番号).Value = "" Then
            For 検索行 = 1 To マスタ件数
                If InStr(1, Cells(行, 貼付け先参照キー列番号).Value, データ(検索行, 1), 1) = 1 Then 'ID 参照キー★★★
                    Cells(行, 貼付け先対象列番号).Value = データ(検索行, 2)     '登録データ ★★★
                    Exit For
                End If
            Next 検索行
        End If

    Next 行
    MsgBox "処理終了"
End Sub

　解説：
　配列「データ」の値を、一気にセル範囲に書き出したり、セル範囲の値を、一気に配列に読み込むことで、処理の高速化を図っています。

　Sheets または Worksheets オブジェクトの Add メソッドは、新しいワークシート、グラフ シート、またはマクロ シートを作成します。新しいワークシートがアクティブ シートになります。

expression.Add(Before, After, Count, Type)

expression 必ず指定します。対象となるオブジェクトへの参照を返すオブジェクト式を指定します。
Before 省略可能です。バリアント型 (Variant) の値を使用します。指定したオブジェクトのシートの直前に、新しい シートを追加します。
After 省略可能です。バリアント型 (Variant) の値を使用します。指定したオブジェクトのシートの直後に、新しい シートを追加します。
Count 省略可能です。バリアント型 (Variant) の値を使用します。追加するシートの数を指定します。既定値は 1 です。
Type 省略可能です。バリアント型 (Variant) の値を使用します。ワークシートの種類を指定します。使用できる定数は、XlSheetType クラスの xlWorksheet、xlChart、xlExcel4MacroSheet、xlExcel4IntlMacroSheet のいずれかです。既存のテンプレートに基づいてシートを挿入する場合は、テンプレートのパスを指定してください。既定値は xlWorksheet です。

　引数 Before と引数 After をともに省略すると、アクティブ シートの直前に新しいシートが追加されます。

この種類の目次に戻る↑　索引へ↓　トップページに戻る

部分一致



Option Explicit
Option Base 1

Dim 行 As Integer
Dim マスタ件数 As Integer
Dim 最終行 As Integer
Dim 検索行 As Integer

Sub データコピー部分一致() '★★★部分★★★一致★★★
Dim データ()

    Call 参照関係の読み込み

    'マスタデータを配列に読み込む
    Workbooks(コピー元ブック名).Worksheets(コピー元シート名).Activate
    
    最終行 = Cells(ActiveSheet.Rows.Count, コピー元参照キー列番号).End(xlUp).Row
    マスタ件数 = 最終行 - コピー元キー開始行 + 1
    
    ReDim データ(マスタ件数, 2)
    
    For 行 = コピー元キー開始行 To 最終行
        データ(行 - コピー元キー開始行 + 1, 1) _
        = Cells(行, コピー元参照キー列番号).Value 'ID 参照キー★★★
        データ(行 - コピー元キー開始行 + 1, 2) _
        = "'" & Cells(行, コピー対象列番号).Value '登録データ ★★★
    Next 行
    
    'キーの文字数の逆順に並び替える。
    '理由は、例えば、A、ABとあったとき、文字数の逆順にしておかないと、全てAで当たってしまうから。
    ThisWorkbook.Activate
    Worksheets.Add after:=Worksheets("Sheet1")
    ActiveSheet.Name = "ソートワーク"
    ThisWorkbook.Worksheets("ソートワーク").Range("A1").Resize(マスタ件数, 2).Value = データ
    
    For 行 = 1 To マスタ件数
        Range("C1").Cells(行, 1).Value = Len(Range("A1").Cells(行, 1).Value)
    Next 行
    
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Sort _
        Key1:=Range("C1"), _
        Order1:=xlDescending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlPinYin

    ReDim データ(マスタ件数, 2)
    
    データ = ThisWorkbook.Worksheets("ソートワーク").Range("A1").Resize(マスタ件数, 2).Value

    Application.DisplayAlerts = False
    ThisWorkbook.Worksheets("ソートワーク").Delete
    Application.DisplayAlerts = True
    
    'コピー貼付けする
    
    Workbooks(貼付け先ブック名).Worksheets(貼付け先シート名).Activate
    
    最終行 = Cells(ActiveSheet.Rows.Count, 貼付け先参照キー列番号).End(xlUp).Row
    For 行 = 貼付け先キー開始行 To 最終行
        If Cells(行, 貼付け先対象列番号).Value = "" Then
            For 検索行 = 1 To マスタ件数
                If InStr(1, Cells(行, 貼付け先参照キー列番号).Value, データ(検索行, 1), 1) Then 'ID 参照キー★★★
                    Cells(行, 貼付け先対象列番号).Value = データ(検索行, 2)     '登録データ ★★★
                    Exit For
                End If
            Next 検索行
        End If

    Next 行
    MsgBox "処理終了"
End Sub



この種類の目次に戻る↑　索引へ↓　トップページに戻る


Excel関数の VLOOKUP をマクロで(セル置換)

　上は、コピー先のキーを使って、空いている列に、データをコピーしています。
　ここでは、セルのデータを、直接置換してしまうマクロを、紹介します。

　日本語で書かれた、ER図を、専用の英語辞書を使って、英語版のER図に修正するために作りました。

　(1)．置換対象のセルに、括弧や記号が入っている場合にも、括弧で範囲を分けて、置換できるように、工夫？しました。
　(2)．セルデータだけでなく、テキスト・ボックスの文字列も、置換できるようにしています。
　(3)．テキスト・ボックスは、グループ化されていると、テキストの編集ができないため、前もって、グループ解除しています。
　(4)．テキスト・ボックスの中のテキストに、改行が入っている場合にも、対応しました。

このマクロをダウンロードできます。→VLookUpReplaceCellsVBA02.xls


Option Explicit
Option Base 1

Dim 行 As Integer
Dim 列 As Integer
Dim 開始行 As Integer
Dim 開始列 As Integer

Dim マスタ件数 As Integer
Dim 最終行 As Integer
Dim 最終列 As Integer
Dim 検索行 As Integer
Dim 変更前 As Variant
Public Stime As Variant
Public Etime As Variant
Dim 文字数 As Integer
Dim 左 As String
Dim 中 As String
Dim 右 As String
Dim 開始位置 As Integer
Dim 終了位置 As Integer
Dim ワークシート As Worksheet
Dim テキストボックス数 As Integer
Dim 箱 As Integer
Dim セル中の対応カッコの数 As Integer

Dim 文字配列
Dim 改行数 As Integer
Dim 改行 As Integer


Sub セルデータ置換() '★★★★
   Dim データ()

   Stime = Now()

   Call 参照関係の読み込み

   'マスタデータを配列に読み込む
       'マスタ側のブック名とマスタ側のテーブル名
   Workbooks(コピー元ブック名).Worksheets(コピー元シート名).Activate
   
   最終行 = Cells(ActiveSheet.Rows.Count, コピー元参照キー列番号).End(xlUp).Row
   マスタ件数 = 最終行 - コピー元キー開始行 + 1
   
   ReDim データ(マスタ件数, 2)
   
   For 行 = コピー元キー開始行 To 最終行
      If Cells(行, コピー対象列番号).Value <> "" Then '登録データ ★★★
          データ(行 - コピー元キー開始行 + 1, 1) _
          = Cells(行, コピー元参照キー列番号).Value 'ID 参照キー★★★
          データ(行 - コピー元キー開始行 + 1, 2) _
          = Cells(行, コピー対象列番号).Value '登録データ ★★★
      End If
   Next 行
    
    
    'コピー貼付けする
        '登録側のブック名、とテーブル名
    Workbooks(貼付け先ブック名).Worksheets(貼付け先シート名).Activate
    
    
   If 置換対象列番号 = 0 And 置換対象行番号 = 0 Then
    
        開始行 = 1
        最終行 = Cells.SpecialCells(xlLastCell).Row
        開始列 = 1
        最終列 = Cells.SpecialCells(xlLastCell).Column
   
   ElseIf 置換対象列番号 = 0 And 置換対象行番号 <> 0 Then
   
        開始行 = 置換対象行番号
        最終行 = 置換対象行番号
        
        開始列 = 1
        最終列 = Cells(置換対象行番号, ActiveSheet.Columns.Count).End(xlToLeft).Column
    
   Else '列指定の場合(両方指定の場合は、列指定のみ有効)
        'If 置換対象列番号 <> 0 And 置換対象行番号 = 0 Then
        'If 置換対象列番号 <> 0 And 置換対象行番号 <> 0 Then
    
        開始行 = 1
        最終行 = Cells(ActiveSheet.Rows.Count, 置換対象列番号).End(xlUp).Row
        
        開始列 = 置換対象列番号
        最終列 = 置換対象列番号
    
    End If
   
'★★セル置換開始★★

   For 列 = 開始列 To 最終列
      For 行 = 開始行 To 最終行
      
         変更前 = Trim(Range("A1").Cells(行, 列).Value)
         
         '半角カッコと全角カッコの不整合があるため、
         '前処理で、半角全角カッコを、半角に統一
         If InStr(変更前, "（") Or InStr(変更前, "）") Then
            変更前 = Replace(変更前, "（", "(", 1, -1, 0)
            変更前 = Replace(変更前, "）", ")", 1, -1, 0)
            Range("A1").Cells(行, 列).Value = 変更前
         End If
         
        'セルに文字列が存在する場合のみ、処理
        If 変更前 <> "" Then
            変更前 = CStr(変更前)
            
            '★素直に、セルの内容全体が、合致したものを置換
         
            For 検索行 = 1 To マスタ件数
                If 変更前 = データ(検索行, 1) Then 'ID 参照キー★★★
                  変更前 = データ(検索行, 2) '登録データ ★★★
                  Range("A1").Cells(行, 列).Value = 変更前
                  GoTo 次のセルに 'セル全体が合致すれば、このセルは完了
                End If
            Next 検索行
            
            '両端が、括弧などで囲まれている場合、内側だけを照合して、該当すれば置換
            文字数 = Len(変更前)
            If 文字数 > 2 Then
               左 = Left(変更前, 1)
               中 = Trim(Mid(変更前, 2, 文字数 - 2))
               右 = Right(変更前, 1)
               
               For 検索行 = 1 To マスタ件数
                   If 中 = データ(検索行, 1) Then 'ID 参照キー★★★
                     中 = データ(検索行, 2)  '登録データ ★★★
                     変更前 = 左 & 中 & 右   '登録データ ★★★
                     Range("A1").Cells(行, 列).Value = 変更前
                     GoTo 次のセルに 'セル全体が合致すれば、このセルは完了
                   End If
               Next 検索行
            End If 'セルの文字数が2以上について
            
            '左端に、●など、記号が入っている場合、2文字目からを対象に置換
            文字数 = Len(変更前)
            If 文字数 > 2 Then
               左 = Left(変更前, 1)
               中 = Trim(Right(変更前, 文字数 - 1))
               For 検索行 = 1 To マスタ件数
                   If 中 = データ(検索行, 1) Then 'ID 参照キー★★★
                     中 = データ(検索行, 2)  '登録データ ★★★
                     変更前 = 左 & 中   '登録データ ★★★
                     Range("A1").Cells(行, 列).Value = 変更前
                     GoTo 次のセルに 'セル全体が合致すれば、このセルは完了
                   End If
               Next 検索行
            End If 'セルの文字数が2以上について
            
            '右端に、●など、記号が入っている場合、右端を除いて置換
            文字数 = Len(変更前)
            If 文字数 > 2 Then
               中 = Trim(Left(変更前, 文字数 - 1))
               右 = Right(変更前, 1)
               For 検索行 = 1 To マスタ件数
                   If 中 = データ(検索行, 1) Then 'ID 参照キー★★★
                     中 = データ(検索行, 2)  '登録データ ★★★
                     変更前 = 中 & 右 '登録データ ★★★
                     Range("A1").Cells(行, 列).Value = 変更前
                     GoTo 次のセルに 'セル全体が合致すれば、このセルは完了
                   End If
               Next 検索行
            End If 'セルの文字数が2以上について
            
            
         '★ここからは、セルにカッコを含む場合、カッコの前後を区分して、照合置換する★
            
            '途中に、括弧で始まっている場合は、「カッコの手前」までを対象にして置換
            文字数 = Len(変更前)
            If 文字数 > 2 Then
               開始位置 = InStr(1, 変更前, "（")
               If 開始位置 = 0 Then
                  開始位置 = InStr(1, 変更前, "(")
               End If
               If 開始位置 > 1 Then
                  中 = Trim(Left(変更前, 開始位置 - 1))
                  右 = Right(変更前, 文字数 - 開始位置 + 1)
                  For 検索行 = 1 To マスタ件数
                      If 中 = データ(検索行, 1) Then 'ID 参照キー★★★
                           中 = データ(検索行, 2)  '登録データ ★★★
                           変更前 = 中 & 右 '登録データ ★★★
                          Range("A1").Cells(行, 列).Value = 変更前
                          Exit For
                      End If
                  Next 検索行
               End If '途中に、括弧で始まっている場合
            End If 'セルの文字数が2以上について

            '途中に、括弧で終わっている場合は、最後の「カッコの後ろを対象」にして置換
            文字数 = Len(変更前)
            If 文字数 > 2 Then
                  終了位置 = InStrRev(変更前, ")")
               If 終了位置 > 1 And 終了位置 <> 文字数 Then
                  左 = Left(変更前, 終了位置)
                  中 = Trim(Right(変更前, 文字数 - 終了位置))

                  For 検索行 = 1 To マスタ件数
                      If 中 = データ(検索行, 1) Then 'ID 参照キー★★★
                        中 = データ(検索行, 2)  '登録データ ★★★
                        変更前 = 左 & 中 '登録データ ★★★
                        Range("A1").Cells(行, 列).Value = 変更前
                        Exit For
                      End If
                  Next 検索行
               End If '括弧で終わっている場合
            End If 'セルの文字数が2以上について
            
            '途中で、括弧で囲まれている場合は、カッコ内を対象にして置換
            文字数 = Len(変更前)
            終了位置 = 1
            
            If 文字数 > 2 Then
               For セル中の対応カッコの数 = 1 To 2
                  If 終了位置 > 0 Then
                     開始位置 = InStr(終了位置, 変更前, "(") '半角カッコ
                     終了位置 = InStr(終了位置, 変更前, ")")
                     If 開始位置 > 0 And 終了位置 > 開始位置 Then
                        左 = Left(変更前, 開始位置)
                        中 = Trim(Mid(変更前, 開始位置 + 1, 終了位置 - 開始位置 - 1))
                        右 = Right(変更前, 文字数 - 終了位置 + 1)
                        For 検索行 = 1 To マスタ件数
                            If 中 = データ(検索行, 1) Then 'ID 参照キー★★★
                                 中 = データ(検索行, 2)  '登録データ ★★★
                                  変更前 = 左 & 中 & 右 '登録データ ★★★
                                Range("A1").Cells(行, 列).Value = 変更前
                                Exit For
                            End If
                        Next 検索行
                     End If 'カッコに挟まれた部分
                  End If '右カッコを含む場合のみ
               Next セル中の対応カッコの数
            End If 'セルの文字数が2以上について


            '途中で、括弧が入れ子になっている「**(☆☆(**))」の途中で囲まれている場合は、
            '「カッコの途中」も対象にして置換
            文字数 = Len(変更前)
            If 文字数 > 2 Then
               開始位置 = InStr(1, 変更前, "(") '半角左カッコ
               If 開始位置 > 0 Then
                  終了位置 = InStr(開始位置 + 1, 変更前, "(") '半角左カッコ
                  If 終了位置 > 開始位置 Then
                     左 = Left(変更前, 開始位置)
                     中 = Trim(Mid(変更前, 開始位置 + 1, 終了位置 - 開始位置 - 1))
                     右 = Right(変更前, 文字数 - 終了位置 + 1)
                     For 検索行 = 1 To マスタ件数
                         If 中 = データ(検索行, 1) Then 'ID 参照キー★★★
                           中 = データ(検索行, 2)  '登録データ ★★★
                           変更前 = 左 & 中 & 右 '登録データ ★★★
                           Range("A1").Cells(行, 列).Value = 変更前
                           Exit For
                         End If
                     Next 検索行
                  End If '終了位置 > 開始位置
               End If 'カッコに挟まれた部分
            End If 'セルの文字数が2以上について
               
        End If  'セルに値が有るものについて、値を、辞書で変換
次のセルに:
      Next 行
   Next 列
   
'★★セル置換終わり★★

'*******************************************************

'★★テキストボックス置換★★

   If テキストボックス判定 <> "" Then
   
    ActiveSheet.Shapes.SelectAll
    Selection.ShapeRange.Ungroup.Select 'テキストボックス(図形)のグループ解除

      Set ワークシート = Workbooks(貼付け先ブック名).Worksheets(貼付け先シート名)
      テキストボックス数 = ワークシート.TextBoxes.Count
      
      For 箱 = 1 To テキストボックス数
   
         変更前 = Trim(ワークシート.TextBoxes(箱).Text)
         
         If 変更前 <> "" Then
         
            '前処理で、半角全角カッコを、半角に統一
            If InStr(変更前, "（") Or InStr(変更前, "）") Then
               変更前 = Replace(変更前, "（", "(", 1, -1, 0)
               変更前 = Replace(変更前, "）", ")", 1, -1, 0)
            End If
   
           'テキスト・ボックス内改行を、1行ずつに分割
            文字配列 = Split(変更前, vbLf)
            '改行数を取得
            改行数 = UBound(文字配列)

            For 改行 = 0 To 改行数
               変更前 = 文字配列(改行)
               
               '★素直に、テキスト・ボックスのテキスト全体が、合致したものを置換
      
               For 検索行 = 1 To マスタ件数
                   If 変更前 = データ(検索行, 1) Then 'ID 参照キー★★★
                     変更前 = データ(検索行, 2)  '登録データ ★★★
                     文字配列(改行) = 変更前  '登録データ ★★★
                     GoTo 次の行に
                   End If
               Next 検索行
                  
               '★ここからは、セルにカッコを含む場合、カッコの前後を区分して、照合置換する★
               
               '途中に、括弧で始まっている場合は、「カッコの手前」までを対象にして置換
               文字数 = Len(変更前)
               If 文字数 > 2 Then
                  開始位置 = InStr(1, 変更前, "（")
                  If 開始位置 = 0 Then
                     開始位置 = InStr(1, 変更前, "(")
                  End If
                  If 開始位置 > 1 Then
                     中 = Trim(Left(変更前, 開始位置 - 1))
                     右 = Right(変更前, 文字数 - 開始位置 + 1)
                     For 検索行 = 1 To マスタ件数
                         If 中 = データ(検索行, 1) Then 'ID 参照キー★★★
                              中 = データ(検索行, 2)  '登録データ ★★★
                              変更前 = 中 & 右 '登録データ ★★★
                             文字配列(改行) = 変更前
                             Exit For
                         End If
                     Next 検索行
                  End If '途中に、括弧で始まっている場合
               End If 'テキストボックスの文字数が2以上について
      
               '途中に、括弧で終わっている場合は、最後の「カッコの後ろを対象」にして置換
               文字数 = Len(変更前)
               If 文字数 > 2 Then
                     終了位置 = InStrRev(変更前, ")")
                  If 終了位置 > 1 And 終了位置 <> 文字数 Then
                     左 = Left(変更前, 終了位置)
                     中 = Trim(Right(変更前, 文字数 - 終了位置))
      
                     For 検索行 = 1 To マスタ件数
                         If 中 = データ(検索行, 1) Then 'ID 参照キー★★★
                           中 = データ(検索行, 2)  '登録データ ★★★
                           変更前 = 左 & 中 '登録データ ★★★
                           文字配列(改行) = 変更前
                           Exit For
                         End If
                     Next 検索行
                  End If '括弧で終わっている場合
               End If 'テキストボックスの文字数が2以上について
                  
               '途中で、括弧で囲まれている場合は、カッコ内を対象にして置換
               文字数 = Len(変更前)
               終了位置 = 1
               
               If 文字数 > 2 Then
                  For セル中の対応カッコの数 = 1 To 2
                     If 終了位置 > 0 Then
                        開始位置 = InStr(終了位置, 変更前, "(") '半角カッコ
                        終了位置 = InStr(終了位置, 変更前, ")")
                        If 開始位置 > 0 And 終了位置 > 開始位置 Then
                           左 = Left(変更前, 開始位置)
                           中 = Trim(Mid(変更前, 開始位置 + 1, 終了位置 - 開始位置 - 1))
                           右 = Right(変更前, 文字数 - 終了位置 + 1)
                           For 検索行 = 1 To マスタ件数
                               If 中 = データ(検索行, 1) Then 'ID 参照キー★★★
                                    中 = データ(検索行, 2)  '登録データ ★★★
                                     変更前 = 左 & 中 & 右 '登録データ ★★★
                                   文字配列(改行) = 変更前
                                   Exit For
                               End If
                           Next 検索行
                        End If 'カッコに挟まれた部分
                     End If '右カッコを含む場合のみ
                  Next セル中の対応カッコの数
               End If 'テキストボックスの文字数が2以上について
      
      
               '途中で、括弧が入れ子になっている「**(☆☆(**))」の途中で囲まれている場合は、
               '「カッコの途中」も対象にして置換
               文字数 = Len(変更前)
               If 文字数 > 2 Then
                  開始位置 = InStr(1, 変更前, "(") '半角左カッコ
                  If 開始位置 > 0 Then
                     終了位置 = InStr(開始位置 + 1, 変更前, "(") '半角左カッコ
                     If 終了位置 > 開始位置 Then
                        左 = Left(変更前, 開始位置)
                        中 = Trim(Mid(変更前, 開始位置 + 1, 終了位置 - 開始位置 - 1))
                        右 = Right(変更前, 文字数 - 終了位置 + 1)
                        For 検索行 = 1 To マスタ件数
                            If 中 = データ(検索行, 1) Then 'ID 参照キー★★★
                              中 = データ(検索行, 2)  '登録データ ★★★
                              変更前 = 左 & 中 & 右 '登録データ ★★★
                              文字配列(改行) = 変更前
                              Exit For
                            End If
                        Next 検索行
                     End If '終了位置 > 開始位置
                  End If 'カッコに挟まれた部分
               End If 'テキストボックスの文字数が2以上について
次の行に:
             Next 改行 'テキスト・ボックス内の次の行
             
             変更前 = Join(文字配列, vbLf)
             ワークシート.TextBoxes(箱).Text = 変更前
          End If 'テキスト・ボックスが空白以外

      Next 箱
   End If

'★★テキストボックス置換終わり★★
'********************************************************
       ActiveSheet.Shapes.SelectAll
    Selection.ShapeRange.Group
    
       Etime = Now()
    MsgBox "処理が終了しました。" & Chr(13) & "処理時間は、" & Format(Etime - Stime, "nn分ss秒") & " でした。", vbOKOnly

End Sub

　解説：
　Shapes コレクションは、指定された文書のすべての Shape オブジェクトのコレクションです。
　Shape オブジェクトは、オートシェイプ、フリーフォーム、OLE オブジェクト、またはピクチャなどの描画レイヤのオブジェクトを表します。

複数のオブジェクト
┗Shapes
　┗ShapeRange

　ShapeRange コレクション
http://msdn.microsoft.com/ja-jp/library/cc360616.aspx
　Shape オブジェクト
http://msdn.microsoft.com/ja-jp/library/cc360579.aspx

　使い方
　Shapes コレクションを取得するには、Shapes プロパティを使用します。
　次の使用例は、myDocument のすべての図形を選択します。 

Set myDocument = Worksheets(1)
myDocument.Shapes.SelectAll
　SelectAll メソッド
http://msdn.microsoft.com/ja-jp/library/cc359674.aspx

　追記：シートのすべての図形に対して同時にプロパティの削除や設定などを実行する場合は、すべての図形を選択し、ShapeRange プロパティでシートのすべての図形を含む ShapeRange コレクションを作成して、そのコレクションに適切なプロパティまたはメソッドを設定します。

　単体の Shape オブジェクトを取得するには、Shapes(index) プロパティを使用します。
　引数 index には、図形の名前またはインデックス番号を指定します。
　次の使用例は、myDocument の図形 1 に既定の塗りつぶしのグラデーションを設定します。

Set myDocument = Worksheets(1)
myDocument.Shapes(1).Fill.PresetGradient _
    msoGradientHorizontal, 1, msoGradientBrass

　文書のオートシェイプだけを処理したり、選択した図形だけを処理する場合など、文書の図形のサブセットを処理する場合は、処理する図形を含む ShapeRange コレクションを作成する必要があります。
　単一の図形または同時に複数の図形を処理する方法については、ヘルプの「図形で作業する (描画オブジェクト)」を参照してください。

　Shapes コレクションのサブセットを表す ShapeRange コレクションを取得するには、Shapes.Range(index) プロパティを使用します。
　引数 index には、図形の名前またはインデックス番号、あるいは複数の図形名またはインデックス番号の配列を指定します。
　次の使用例は、myDocument の図形 1 および図形 3 に塗りつぶしのパターンを設定します。

Set myDocument = Worksheets(1)
myDocument.Shapes.Range(Array(1, 3)).Fill.Patterned _
    msoPatternHorizontalBrick

　追記：
　ワークシートの ActiveX コントロールは、2 つの名前を持ちます。
　シートを表示したときに名前ボックスで確認できる図形の名前、およびプロパティ ウィンドウの Name プロパティでコントロールのコード名を確認できます。
　最初にワークシートに追加したコントロールでは、図形の名前とコード名が一致しています。しかし、図形の名前、コード名のどちらかを変更しても、もう片方の名前が一致するように自動的に変更されることはありません。

　コントロールのイベント プロシージャの場合は、コントロールのコード名を使います。
　Shapes または OLEObjects コレクションからコントロールを取得する場合は、コード名ではなく、図形の名前を使ってコントロールを指定します。
　たとえば、コード名および図形の名前が既定の CheckBox1 というチェック ボックスを追加したと仮定します。コントロールの [プロパティ] ウィンドウで Name プロパティを chkFinished と設定してコード名を変更した場合、イベント プロシージャでは必ずコントロールのコード名を使い、Shapes または OLEObject コレクションからコントロールを取得する場合、次のように CheckBox1 を使います。

Private Sub chkFinished_Click()
    ActiveSheet.OLEObjects("CheckBox1").Object.Value = 1
End Sub

　Shape および ShapeRange オブジェクトの Ungroup メソッドは、指定された図形または図形範囲の図形のグループ化を解除します。指定された図形または図形範囲内の図や OLE オブジェクトを分解します。
　グループ解除された図形を 1 つの ShapeRange オブジェクトとして返します。

　Ungroup メソッド
http://msdn.microsoft.com/ja-jp/library/cc360055.aspx

　次の使用例は、myDocument の図形のグループ化を解除し、図または OLE オブジェクトを分解します。

Set myDocument = Worksheets(1)
For Each s In myDocument.Shapes
    s.Ungroup
Next

　次の使用例は、文書の図または OLE オブジェクトを分解せずに、myDocument の図形のグループ化を解除します。

Set myDocument = Worksheets(1)
For Each s In myDocument.Shapes
    If s.Type = msoGroup Then s.Ungroup


　TextBoxes プロパティは Excel.TextBox のコレクションです。
　シェイプの一種である、テキストボックスの値を、コードで取得・設定することができます。
　Excel の TextBox のテキスト・データを取得したり、設定したりするときに使います。
http://msdn.microsoft.com/ja-jp/library/microsoft.office.interop.excel.textboxes_properties(VS.80).aspx

この種類の目次に戻る↑　この種類の続きを見る↓　索引へ↓　トップページに戻る



ホームページのトップに戻る