Excel VBA 文字列操作

Dim MyString
MyString = String(5, "*")    ' Returns "*****".
MyString = String(5, 42)     ' Returns "*****".
MyString = String(10, "ABC")    ' Returns "AAAAAAAAAA".

Dim MyString
' Returns a string with 10 spaces.
MyString = Space(10)

' Insert 10 spaces between two strings.
MyString = "Hello" & Space(10) & "World"

Function 出現回数(検索される文字列 As String, _
                          検索する文字列 As String, _
                          Optional lngCompare _
                          As VbCompareMethod) As Long

   ' 特定の文字または文字列が見つかった回数を数えます。
   ' lngCompare 引数を省略すると、バイナリで比較を行ないます。

   Dim lngPos       As Long
   Dim lngTemp      As Long
   Dim lngCount     As Long

   ' 開始位置を指定してください。
   ' 最初のループでは開始位置を必要としませんが、以降のパスで必要になります。
   lngPos = 1
   ' ループを少なくとも一度実行します。
   Do
      '「検索する文字列」が、最初に見つかった位置を保存します。
      lngPos = InStr(lngPos, 検索される文字列, 検索する文字列, lngCompare)
      ' 位置を一時的な変数に保管します。
      lngTemp = lngPos
      '「検索する文字列」があるかどうかチェックします。
      If lngPos > 0 Then
         ' 増加カウンター変数。
         lngCount = lngCount + 1
         ' 新しい検索開始位置を設定します。
         lngPos = lngPos + Len(検索する文字列)
      End If
   ' 最後まで見つけるためにループします。
   Loop Until lngPos = 0
   ' 見つかった発生回数を返します。
   出現回数 = lngCount
End Function

Option Explicit

Sub 英字削除()
Dim i As Integer
Dim j As Integer

ThisWorkbook.Worksheets("Sheet1").Activate
For i = 1 To Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row - 1
                        'A2以下のセルにデータがあるものを対象にします。
                        'Cells(行,列)の列を1としてA列の最終行までの行数をカウントしますが、
                        '下でA2を開始行にしているため、1引いています。
                        'Excelの最終行を取得の項を参照下さい。
    If Range("A2").Cells(i, 1).Value <> "" Then
                        'A2を基準に、Cells(i,1)で、行を下にずらしながら作業します。
                        'この場合、Cells(1,1)は、A2のセルです。
                        '3文字め以降、最後の文字までチェックします。
        For j = 3 To Len(Range("A2").Cells(i, 1).Value)
            If Mid(Range("A2").Cells(i, 1).Value, j, 1) > "9" Then Exit For
                         '英字なら抜けます。これで英字部分の開始桁数が分かります。
        Next j
        Range("B2").Cells(i, 1).Value = Left(Range("A2").Cells(i, 1).Value, j - 1)
    End If
Next i

End Sub

Worksheets("Sheet1").Range("A5").Value = _
    Worksheets("Sheet1").Range("A1").Value

   '前回取得の銘柄データを削除
   Range("A2:G" & 前回最終行).ClearContents

Range(列文字 & "1")

'★列名を列番号に変換★
Function 列番号(列名 As String) As Integer

   If Len(列名) = 1 Then
      列番号 = Asc(UCase(列名)) - 64
      If 列番号 < 1 Or 列番号 > 26 Then
         MsgBox "列名が不正です。列名：" & 列名 & " 列番号：" & 列番号
            End
      End If
        
   ElseIf Len(列名) = 2 Then
      列番号 = Asc(UCase(Right(列名, 1))) - 64 + (Asc(UCase(Left(列名, 1))) - 64) * 26
      If 列番号 < 26 Or 列番号 > 256 Then
         'この関数は、Excel 2003までの行と列の最大数、行数 65,536 、列数 256(列名 IV) を前提。
         'http://bicycle.life.coocan.jp/takamints/index.php/techtips/xlsColNumMap
         'Excel 2007〜では、ワークシートのサイズは、 1,048,576 行 x 16,384 列 に拡大した。

         MsgBox "列オーバ。マクロを修正して下さい。列名：" & 列名 & " 列番号：" & 列番号
         End
      End If
   Else
      MsgBox "列オーバ。マクロを修正して下さい。列名：" & 列名
   End If

End Function

Worksheets("Sheet1").Activate
Range("A1:H8").Formula = "=Rand()"    'Range is on the active sheet

Worksheets(1).Range("Criteria").ClearContents

Sub 出現位置テスト()

   Dim 文字列 As String
   Dim パターン As String
   Dim 回数 As Integer

   文字列 = "瀬を早み" & vbTab & "岩にせかるる滝川の" & vbTab & "われても末に" & vbTab & "あはむとぞ思ふ"
   パターン = "\t"

   MsgBox "文字列 = " & 文字列 & vbNewLine _
      & "パターン = " & パターン & vbNewLine _
      & "出現回数= " & 出現回数(文字列, パターン)

   For 回数 = 1 To 出現回数(文字列, パターン)
      MsgBox "回数= " & 回数 & " 文字目= " & 出現位置(文字列, パターン, 回数)
   Next 回数


   文字列 = "お米の国と呼ばれる日本。お米のお国処は、秋田"
   パターン = "お米.*?国" '最短一致

   MsgBox "文字列 = " & 文字列 & vbNewLine _
      & "パターン = " & パターン & vbNewLine _
      & "出現回数= " & 出現回数(文字列, パターン)

   For 回数 = 1 To 出現回数(文字列, パターン)
      MsgBox "回数= " & 回数 & " 文字目= " & 出現位置(文字列, パターン, 回数)
   Next 回数


   文字列 = "H:\Excelマクロ\テスト"
   パターン = "\\" '一つ目の \ は、エスケープ文字

   MsgBox "文字列 = " & 文字列 & vbNewLine _
      & "パターン = " & パターン & vbNewLine _
      & "出現回数= " & 出現回数(文字列, パターン)

   For 回数 = 1 To 出現回数(文字列, パターン)
      MsgBox "回数= " & 回数 & " 文字目= " & 出現位置(文字列, パターン, 回数)
   Next 回数

End Sub


Function 出現位置(検索される文字列 As String, 検索する文字列パターン As String, 出現目 As Integer) As Integer
'ある文字列で2回目3回目に出現するtabの位置を得るには？
'http://okwave.jp/qa/q2325128.html

   Dim 正規表現オブジェクト As RegExp
   Dim Matches As Object

   Set 正規表現オブジェクト = New RegExp

   正規表現オブジェクト.Pattern = 検索する文字列パターン
   正規表現オブジェクト.Global = True

   Set Matches = 正規表現オブジェクト.Execute(検索される文字列)
   '0 オリジンなので 1引く

   出現位置 = Matches(出現目 - 1).FirstIndex + 1

   Set Matches = Nothing
   Set 正規表現オブジェクト = Nothing

End Function


Function 出現回数(検索される文字列 As String, 検索する文字列パターン As String) As Integer
'Excelで自然言語処理
'http://pub.ne.jp/arihagne/

'VBAで正規表現パターンにマッチした数を返す関数
'http://pub.ne.jp/arihagne/?entry_id=2114432

   Dim Matches As Object

   With CreateObject("VBScript.RegExp")
       .Pattern = 検索する文字列パターン
       .IgnoreCase = True
       .Global = True
       Set Matches = .Execute(検索される文字列)
       出現回数 = Matches.Count
   End With

   Set Matches = Nothing

End Function

Sub 文字抽出�@()
    Dim 全角文字数 As Integer
    Dim i As Integer
    Dim 文字列

    For i = 1 To 2
        文字列 = Mid(Range("A1").Cells(i, 1), 3, 5)
        
        全角文字数 = LenB(StrConv(文字列, vbFromUnicode)) - Len(文字列)

        Range("B1").Cells(i, 1).Value = Mid(Range("A1").Cells(i, 1), 3, 5 - 全角文字数)
        Range("C1").Cells(i, 1).Value = Mid(Range("A1").Cells(i, 1), 8 - 全角文字数, 2)
    Next i
End Sub

Sub 文字抽出�A()
    Dim i As Integer

    For i = 1 To 2
        Range("B1").Cells(i, 1).Value = MidMbcs(Range("A1").Cells(i, 1), 3, 5)
        Range("C1").Cells(i, 1).Value = MidMbcs(Range("A1").Cells(i, 1), 8, 2)
    Next i
End Sub

Function MidMbcs(ByVal str As String, start, length)
    MidMbcs = StrConv(MidB(StrConv(str, vbFromUnicode), start, length), vbUnicode)
End Function

   Dim 正規表現オブジェクト As RegExp

   Set 正規表現オブジェクト = New RegExp
   正規表現オブジェクト.Pattern = "[^\x01-\x7E]" '2バイト文字

   If 正規表現オブジェクト.Test(文字列) = True Then
      MsgBox "半角英数以外の文字が含まれています！"
   End If

Sub 全角文字の存在チェック()

   Dim 正規表現オブジェクト As RegExp
   Dim 行数 As Integer
   Dim 文字列 As String

   Set 正規表現オブジェクト = New RegExp
   正規表現オブジェクト.Pattern = "[^\x01-\x7E]" '2バイト文字

   ThisWorkbook.Worksheets("Sheet2").Activate

   For 行数 = 1 To Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row

      文字列 = Range("A1").Cells(行数, 1).Value

      If 正規表現オブジェクト.Test(文字列) = True Then
         Range("C1").Cells(行数, 1).Value = "半角英数以外の文字が含まれています！"
      End If

   Next 行数

End Sub

Function LenMbcs (ByVal str as String)
    LenMbcs = LenB(StrConv(str, vbFromUnicode))
End Function 

Function MidMbcs(ByVal str as String, start, length)
    MidMbcs = StrConv(MidB(StrConv(str, vbFromUnicode), start, length), vbUnicode)
End Function

   MsgBox "このアプリケーションのロケール ID" & vbNewLine _
      & "インストール言語 ： " _
      & Application.LanguageSettings.LanguageID(msoLanguageIDInstall) & vbNewLine _
      & " ユーザー インターフェイス言語 ： " _
      & Application.LanguageSettings.LanguageID(msoLanguageIDUI) & vbNewLine _
      & " ヘルプ言語 ： " _
      & Application.LanguageSettings.LanguageID(msoLanguageIDHelp) & vbNewLine _
      & "実行モード言語 ： " & Application.LanguageSettings.LanguageID(msoLanguageIDExeMode)

If Application.LanguageSettings. _ 
 LanguagePreferredForEditing(msoLanguageIDEnglishUS) Then 
 MsgBox "U.S. English is one of the chosen editing languagess." 
End If

Option Explicit
Sub 表示の違い()
    MsgBox ".value= " & Range("A1").Value _
        & Chr(13) & Chr(10) _
        & ".text  = " & Range("A1").Text
End Sub

Option Explicit
Sub 文字変換()
Dim i As Integer
    For i = 1 To 2
        Range("B1").Cells(i, 1).Value _
        = Chr(34) & Str(Range("A1").Cells(i, 1).Value) & Chr(34)
        Range("C1").Cells(i, 1).Value _
        = Chr(34) & CStr(Range("A1").Cells(i, 1).Value) & Chr(34)
    Next i
End Sub

Option Explicit

Dim か As Integer
Dim ち As Integer
Dim ふ As Integer
Dim ふかかち As Double

Sub 価値かける価値は付加価値()

   For ち = 0 To 9
      For か = 1 To 9
         ふかかち = (か * 10 + ち) ^ 2
         If Len(CStr(ふかかち)) <> 4 Then GoTo スキップ
         
         If Right(CStr(ふかかち), 1) <> CStr(ち) _
            Or Mid(CStr(ふかかち), 2, 1) <> CStr(か) _
            Or Mid(CStr(ふかかち), 3, 1) <> CStr(か) _
            Then GoTo スキップ
                        
         GoTo 解答
スキップ:
      Next か
   Next ち
   
解答:
   If Val(Left(CStr(ふかかち), 1)) * 1000 + か * 100 + か * 10 + ち = ふかかち Then
   
      MsgBox ("か= " & か & " 、ち= " & ち & " 、ふかかち= " & ふかかち)
   Else
      MsgBox ("解答が見つかりませんでした。")
   End If

End Sub

Option Explicit

Sub 英数字を漢数字に変換()

   Const 数字文字 As String = ",一,二,三,四,五,六,七,八,九"
   Const 位文字文字 As String = ",,十,百,千,万,十,百,千,億,十"
   Dim 数字() As String
   Dim 位文字() As String
   Dim 入力数 As Currency
   Dim 桁数 As Integer
   Dim 桁 As Integer
   Dim 出力文字 As String
   Dim 数 As Integer
   Dim 万の位の数字有無 As Boolean
   
   'Split関数を使って、定数配列として格納する
   数字 = Split(数字文字, ",")
   位文字 = Split(位文字文字, ",")
   入力数 = Worksheets("Sheet1").Range("A2").Value
   桁数 = Len(CStr(入力数))
'   Stop
   If 桁数 > 10 Then
      MsgBox "入力する数値は10桁以下にして下さい。"
      Exit Sub
   End If
   出力文字 = ""
   万の位の数字有無 = False
   
   For 桁 = 桁数 To 1 Step -1
      数 = Val(Mid(CStr(入力数), 桁数 - 桁 + 1, 1))
      
      If 数 = 1 Then
         '「一」を表示するのは
         '1の位の時、万(5)の位の時，千万(8)の位の時，億(9)の位の時
         If 桁 = 1 Then
            出力文字 = 出力文字 & 数字(数)
         ElseIf 桁 = 5 Or 桁 = 8 Or 桁 = 9 Then
            出力文字 = 出力文字 & 数字(数) & 位文字(桁)
         Else
            出力文字 = 出力文字 & 位文字(桁)
         End If
         
         If 桁 >= 5 And 桁 < 9 Then
            万の位の数字有無 = True
         End If
         
      ElseIf 数 = 0 Then
         If (桁 = 5 And 万の位の数字有無 = True) Or 桁 = 9 Then
            出力文字 = 出力文字 & 位文字(桁)
         End If
         
      Else '数が 0 でも 1 でもない
         出力文字 = 出力文字 & 数字(数) & 位文字(桁)
         
         If 桁 >= 5 And 桁 < 9 Then
            万の位の数字有無 = True
         End If
         
      End If
      
   Next 桁
   
   Worksheets("Sheet1").Range("D2").Value = 出力文字
End Sub

Sub 年月連続データ()
    Dim 年月(12) As String
    Dim i As Integer
        
    Range("A1").NumberFormat = "yymm"
    Range("A1").Value = Date
    
    Range("A1").AutoFill _
    Destination:=Range("A1").Resize(12, 1), Type:=xlFillMonths
    
    For i = 1 To 12
        年月(i) = Range("A1").Cells(i, 1).Text
    Next i

    '以下は、できたデータを確認するだけ。
    Range("C1").Resize(1, 13).Value = 年月
    
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("A1").Select

End Sub

   Columns("A:A").NumberFormat = "@"        '文字列

Sub 文字列の中の引用符テスト()
   MsgBox "彼は""男の中の男""だ"
End Sub

Dim MyVar, MyCheck
MyVar = "53"                        ' 値を代入します。
MyCheck = IsNumeric(MyVar)        ' True を返します。

MyVar = "459.95"                    ' 値を代入します。
MyCheck = IsNumeric(MyVar)        ' True を返します。

MyVar = "45 Help"                    ' 値を代入します。
MyCheck = IsNumeric(MyVar)        ' False を返します。

Dim 変数

Sub 数値判定()
    Do
        変数 = InputBox("数値を入力して下さい。")
    Loop Until IsNumeric(変数)
    
    MsgBox "入力された値の平方根は　" & Sqr(変数) & "　です。"
End Sub

'***********************************************
'正規表現による半角英数字チェック
'https://nkmrdai.com/vba-regexp-1/
' <チェック項目>
' 半角英数値で入力してあること
'***********************************************
Function 半角か(InputStr As String) As Boolean
    Dim objReg As Object
    Set objReg = CreateObject("VBScript.RegExp")
    objReg.IgnoreCase = True  '大文字と小文字の区別をしない
    objReg.Pattern = "^[a-zA-Z0-9]+$"
    半角か = objReg.Test(InputStr) '英数字がある場合は True、ない場合は False が戻る
    Set objReg = Nothing
End Function

'***********************************************
'正規表現による半角英数字チェック
'https://nkmrdai.com/vba-regexp-1/
' <チェック項目>
' 半角英数値で入力してあること
'【注意】改行文字が含まれると「全角」と誤認します
'***********************************************
Function 全角か(InputStr As String) As Boolean
    Dim objReg As Object
    Set objReg = CreateObject("VBScript.RegExp")
    objReg.IgnoreCase = True  '大文字と小文字の区別をしない
    objReg.Pattern = "[^ -~｡-ﾟ]"
    全角か = objReg.Test(InputStr) '全角文字がある場合は True、ない場合は False が戻る
    Set objReg = Nothing
End Function

   'A 列を、文字列属性にする
   Columns("A:A").NumberFormat = "@"        '文字列
   Range("A1").Select
   
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
   '数字に認識されるものを、文字に変更する。
'   For 処理行 = 2 To 最終行
'      品目番号 = Range("A1").Cells(処理行, 1).Value
'      If IsNumeric(品目番号) = True Then                      '数字と見られるセルについて
'         Range("A1").Cells(処理行, 1).Value = "'" & 品目番号  '�@データの頭にアポストロフィを付ける
'      End If
'   Next 処理行
   
   For 処理行 = 2 To 最終行
      品目番号 = Range("A1").Cells(処理行, 1).Value
      If IsNumeric(品目番号) = True Then                       '数字と見られるセルについて
         Range("A1").Cells(処理行, 1).Value = CStr(品目番号)   '�A文字属性に変更する
      End If
   Next 処理行

Function 半角(文字列 As String)
   'http://billyboy.blog81.fc2.com/blog-entry-84.html
   Dim i As Long
   Dim 暫定文字列 As String
   Dim 一文字 As String
     
   For i = 1 To Len(文字列)
       一文字 = Asc(Mid(文字列, i, 1))
       If 一文字 <= -32102 And 一文字 >= -32177 Then '全角英数字を半角
           一文字 = StrConv(Chr(一文字), vbNarrow)
   '    ElseIf 一文字 <= 221 And 一文字 >= 177 Then '半角カタカナを全角カタカナ
   '        一文字 = StrConv(Chr(一文字), vbWide)
       Else
           一文字 = Chr(一文字)
       End If
             
       暫定文字列 = 暫定文字列 & 一文字
         
   Next i
     
   半角 = 暫定文字列
  
End Function

Function 半角小文字空白無し(文字列 As String) As String

   半角小文字空白無し = Replace(文字列, vbLf, "") 'セル内改行を削除
   半角小文字空白無し = StrConv(半角小文字空白無し, vbNarrow) '全角を半角に
   半角小文字空白無し = Replace(半角小文字空白無し, " ", "")  '空白を削除
   半角小文字空白無し = LCase(半角小文字空白無し) '大文字を小文字に
   
End Function

Function 半角小文字空白無し(文字列 As String) As String

   文字列 = Replace(文字列, vbLf, "") 'セル内改行を削除
   文字列 = StrConv(文字列, vbNarrow) '全角を半角に
   文字列 = Replace(文字列, " ", "")  '空白を削除
   半角小文字空白無し = LCase(文字列) '大文字を小文字に
   
End Function

Function エラーは文字型に変換(入力変数 As Variant) As Variant

   If IsError(入力変数) = True Then
      エラーは文字型に変換 = CStr(入力変数)
   Else
      エラーは文字型に変換 = 入力変数
   End If

End Function

Dim ReturnVal, MyCheck
ReturnVal = UserFunction()
MyCheck = IsError(ReturnVal)        ' True を返します。

      '英数以外が含まれているかどうかを判定
      全角文字数 = LenB(StrConv(文字列, vbFromUnicode)) - Len(文字列)
      '全角があれば、エンコード
      If 全角文字数 > 0 Then
         全角文字数 = Len(文字列)
         If 全角文字数 > 5 Then 全角文字数 = 5
         変換後文字列 = ""
         For 文字カウント = 1 To 全角文字数
            文字コード = AscW(Mid(文字列, 文字カウント, 1))
            If 文字コード < 0 Then
               文字コード = 文字コード + 65536
            End If
            変換後文字列 = 変換後文字列 & "&#" & CStr(文字コード) & ";"
         Next 文字カウント
         文字列 = 変換後文字列
      End If

Option Explicit
Option Base 1

Dim 辞書()
Dim 品目 As String
Dim 名称 As String
Dim 辞書件数 As Integer
Dim 処理件数 As Integer
Dim 検索位置 As Integer
Dim 開始日時 As Variant
Dim 終了日時 As Variant

Sub 名称設定()

    開始日時 = Now
    
'★辞書データの読み込み
    ThisWorkbook.Worksheets("辞書").Activate
    
    辞書件数 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row - 1
    ReDim 辞書(辞書件数, 2)
    辞書 = Range("A2").Resize(辞書件数, 2) '処理速度をあげるため、辞書部分は配列(メモリ)に登録。
    '注：この会社の辞書データでは、なぜか、一文字ワイルドカードとして、*が使われていました。
    '注：辞書データは、前もって条件数が多いものが先に来るように、ソートしておく必要があります。
    
'�@Like 関数 を使う★★★★★★★★★★★

    For 検索位置 = 1 To 辞書件数
        辞書(検索位置, 1) = Replace(辞書(検索位置, 1), "*", "?")
        'ワイルドカードの文字を、Excelの文法(複数の*から、一文字の?)に置換。
    Next 検索位置
    
    ThisWorkbook.Worksheets("データ").Activate
    処理件数 = 0

    Do   '品目を行方向に検索して行く。
    
        処理件数 = 処理件数 + 1
        品目 = Range("A2").Cells(処理件数, 1).Value
        If 品目 = "" Then Exit Do   '品目が無くなったら、ループを抜ける。
    
        For 検索位置 = 1 To 辞書件数
            If 品目 Like 辞書(検索位置, 1) _
            Then 'Likeを使って、ワイルドカード検索。
                Range("B2").Cells(処理件数, 1).Value = 辞書(検索位置, 2)
                Exit For
            End If
            Range("B2").Cells(処理件数, 1).Value = "★辞書無し★"
        Next 検索位置
        
    Loop '品目の登録が、無くなるまで繰返し。
    

'�A．VBScriptの正規表現を使う★★★★★★★★★★★

Dim 正規表現オブジェクト As RegExp
Set 正規表現オブジェクト = New RegExp
    処理件数 = 0
    
    For 検索位置 = 1 To 辞書件数
        辞書(検索位置, 1) = Replace(辞書(検索位置, 1), "?", ".")
        'ワイルドカードの文字を、?から、正規表現一文字の.に置換。
    Next 検索位置
    
    Do   '品目を行方向に検索して行く。
    
        処理件数 = 処理件数 + 1
        品目 = Range("A2").Cells(処理件数, 1).Value
        If 品目 = "" Then Exit Do   '品目が無くなったら、ループを抜ける。
    
        For 検索位置 = 1 To 辞書件数
            正規表現オブジェクト.Pattern = 辞書(検索位置, 1)
            正規表現オブジェクト.IgnoreCase = False
            '大文字小文字を区分する。デフォルトは、True(区別しない)、False(区分する)
            
            If 正規表現オブジェクト.Test(品目) _
            And Len(品目) = Len(辞書(検索位置, 1)) _
            Then '正規表現を使って、ワイルドカード検索。
                Range("C2").Cells(処理件数, 1).Value = 辞書(検索位置, 2)
                Exit For
            End If
            Range("C2").Cells(処理件数, 1).Value = "★辞書無し★"
        Next 検索位置
    
    Loop '品目の登録が、無くなるまで繰返し。
    
    終了日時 = Now
    MsgBox "処理時間は、" _
    & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub

'[返り値]
'検索文字列内に正規表現パターンが見つかった場合：True
'検索文字列内に正規表現パターンが見つからなかった場合：False
Function 正規表現検索(正規表現パターン As String, 検索文字列 As String) As Boolean
    Dim 正規表現オブジェクト As RegExp
    Set 正規表現オブジェクト = New RegExp
    正規表現オブジェクト.Pattern = 正規表現パターン
    正規表現検索 = 正規表現オブジェクト.Test(検索文字列)
End Function

Option Explicit
Option Base 1

Dim 辞書()
Dim 辞書正規表現()
Dim 品目 As String
Dim 名称 As String
Dim 辞書件数 As Integer
Dim 処理件数 As Integer
Dim 検索位置 As Integer
Dim 開始日時 As Variant
Dim 終了日時 As Variant
Dim 名称Like As String
Dim 名称正規表現 As String
Dim 正規表現オブジェクト As RegExp

Dim 接続 As ADODB.Connection
Dim ファイル名 As String
Dim Accessテーブル As ADODB.Recordset
Dim 選択SQL As String


Sub ADO接続でAccessテーブルを更新()

    開始日時 = Now
    Set 正規表現オブジェクト = New RegExp

'★辞書データの読み込み
    ThisWorkbook.Worksheets("辞書").Activate
    
    辞書件数 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row - 1
    ReDim 辞書(辞書件数, 2)
    
    辞書 = Range("A2").Resize(辞書件数, 2) '処理速度をあげるため、辞書部分は配列(メモリ)に登録。
    ThisWorkbook.Worksheets("データ").Activate

    For 検索位置 = 1 To 辞書件数
        辞書(検索位置, 1) = Replace(辞書(検索位置, 1), "*", "?")
        'ワイルドカードの文字を、複数の*から、一文字の?に置換。
    Next 検索位置
    
    ReDim 辞書正規表現(辞書件数, 2)
    辞書正規表現 = 辞書
    For 検索位置 = 1 To 辞書件数
        辞書正規表現(検索位置, 1) = Replace(辞書(検索位置, 1), "?", ".")
        'ワイルドカードの文字を、?から、正規表現一文字の.に置換。
    Next 検索位置

        
'★Accessのデータベースに接続して、テーブルをシーケンシャルに検索して更新
'http://members.at.infoseek.co.jp/kenchan_h/index18.html

    'New キーワードを使用して新規Connectionオブジェクトを生成
    Set 接続 = New ADODB.Connection
    
    '接続先のデータベース
    ファイル名 = "c:\temp\test.mdb"
    
    '接続
    接続.Open _
      "Provider=Microsoft.Jet.OLEDB.4.0;" _
      & "Data Source=" & ファイル名
    
    'レコードセットの作成(SELECT文の実行)
    Set Accessテーブル = New ADODB.Recordset
    選択SQL = "SELECT * FROM データ"
    
    'ADOでレコードセットを作成するとき､レコードの更新､変更､削除ができるように、
    'RecordsetオブジェクトのOpenメソッドを使います｡
    'http://www.geocities.jp/cbc_vbnet/ADO/recordset.html
    'Recordsetオブジェクトの作成（ADO編）
    
    Accessテーブル.Open 選択SQL, 接続, adOpenKeyset, adLockOptimistic
    
    '最終レコードまで順読み込みを行う
    'http://www.happy2-island.com/vbs/cafe02/capter00506.shtml
    Do Until Accessテーブル.EOF = True

       'Accessテーブルの、特定フィールドの値を所得します
       品目 = Accessテーブル("品目")

        'Like を使って、ワイルドカード照合
        For 検索位置 = 1 To 辞書件数
            If 品目 Like 辞書(検索位置, 1) _
            Then 'Likeを使って、ワイルドカード検索。
                名称Like = 辞書(検索位置, 2)
                Exit For
            End If
            名称Like = "★辞書無し★"
        Next 検索位置

        'フィールドの値を変更
        Accessテーブル.Update "名称1", 名称Like
         
         
        '正規表現を使って、ワイルドカード照合
         
        For 検索位置 = 1 To 辞書件数
            正規表現オブジェクト.Pattern = 辞書正規表現(検索位置, 1)
            正規表現オブジェクト.IgnoreCase = False
            '大文字小文字を区分する。デフォルトは、True(区別しない)
            
            If 正規表現オブジェクト.Test(品目) _
            And Len(品目) = Len(辞書正規表現(検索位置, 1)) _
            Then '正規表現を使って、ワイルドカード検索。
                名称正規表現 = 辞書正規表現(検索位置, 2)
                Exit For
            End If
            名称正規表現 = "★辞書無し★"
        Next 検索位置

        'フィールドの値を変更
        Accessテーブル.Update "名称2", 名称正規表現
         
       'レコードの順読み
       Accessテーブル.MoveNext

    Loop
    
    'レコードセットのクローズ
    Accessテーブル.Close
    
    '接続を解除
    接続.Close
    'オブジェクトをクリア
    Set Accessテーブル = Nothing
    Set 接続 = Nothing
    Set 正規表現オブジェクト = Nothing
    
    終了日時 = Now
    MsgBox "処理時間は、" _
    & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub

Option Explicit
Option Base 1

Dim 辞書()
Dim 品目 As String
Dim 名称 As String
Dim 辞書件数 As Integer
Dim 処理件数 As Integer
Dim 検索位置 As Integer
Dim 開始日時 As Variant
Dim 終了日時 As Variant
Dim 名称Like As String
Dim 名称正規表現 As String
Dim 正規表現オブジェクト As RegExp
Dim Matches

Dim 接続 As ADODB.Connection
Dim ファイル名 As String
Dim Accessテーブル As ADODB.Recordset
Dim 選択SQL As String
Dim AccessDB名 As String
Dim Accessテーブル名 As String
Dim 対象項目名 As String
Dim 現在のパス As String


Sub ADO接続でAccessテーブルを更新()

    開始日時 = Now
    Set 正規表現オブジェクト = New RegExp

   '処理の前提のパラメータを設定
   現在のパス = ThisWorkbook.Path
   ThisWorkbook.Worksheets("辞書").Activate
   対象項目名 = Range("A1").Value
   AccessDB名 = Range("B1").Value
   Accessテーブル名 = Range("C1").Value
    
    '★辞書データの読み込み
    辞書件数 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row - 1
    ReDim 辞書(辞書件数, 2)
    
    辞書 = Range("A2").Resize(辞書件数, 2) '処理速度をあげるため、辞書部分は配列(メモリ)に登録。

   '注意：セルB2以下の項目名は、前もって Access のテーブルデザインで、項目追加されていること。

        
'★Accessのデータベースに接続して、テーブルをシーケンシャルに検索して更新
'http://members.at.infoseek.co.jp/kenchan_h/index18.html

    'New キーワードを使用して新規Connectionオブジェクトを生成
    Set 接続 = New ADODB.Connection
    
   '接続先のデータベース
    ファイル名 = 現在のパス & "\" & AccessDB名
    
    '接続
    接続.Open _
      "Provider=Microsoft.Jet.OLEDB.4.0;" _
      & "Data Source=" & ファイル名
    
    'レコードセットの作成(SELECT文の実行)
    Set Accessテーブル = New ADODB.Recordset
    選択SQL = "SELECT * FROM " & Accessテーブル名
    
    'ADOでレコードセットを作成するとき､レコードの更新､変更､削除ができるように、
    'RecordsetオブジェクトのOpenメソッドを使います｡
    'http://www.geocities.jp/cbc_vbnet/ADO/recordset.html
    'Recordsetオブジェクトの作成（ADO編）
    
    Accessテーブル.Open 選択SQL, 接続, adOpenKeyset, adLockOptimistic
    
    '最終レコードまで順読み込みを行う
    Do Until Accessテーブル.EOF = True

       'Accessテーブルの、特定フィールドの値を取得します
       品目 = Accessテーブル(対象項目名)

        '正規表現を使って、ワイルドカード照合
         
        For 検索位置 = 1 To 辞書件数
            正規表現オブジェクト.Pattern = 辞書(検索位置, 1)
            正規表現オブジェクト.IgnoreCase = False
            '大文字小文字を区分する。デフォルトは、True(区別しない)
            正規表現オブジェクト.Global = True   ' 文字列全体を検索するように設定します。

            Set Matches = 正規表現オブジェクト.Execute(品目)   ' 検索を実行します。
            'フィールドの値を変更
             Accessテーブル.Update 辞書(検索位置, 2), Matches.Count
             'http://codezine.jp/article/detail/1655?p=2
        Next 検索位置
                     
       'レコードの順読み
       Accessテーブル.MoveNext

    Loop
    
    'レコードセットのクローズ
    Accessテーブル.Close
    
    '接続を解除
    接続.Close
    'オブジェクトをクリア
    Set Accessテーブル = Nothing
    Set 接続 = Nothing
    Set 正規表現オブジェクト = Nothing
    
    終了日時 = Now
    MsgBox "処理時間は、" _
    & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub