ユーザー定義関数 索引数取得

'''
''''カスタム関数　索引数取得
'''
'''Function 索引数取得(引数 As Range) As Variant
'''
''''    Dim 引数 As Range
''''    Set 引数 = Application.ThisCell
'''
'''    '=IF(IsHidden([@五十音]),"",索引数取得)
'''    '=IF(IsHidden([@五十音]),"",IF(OFFSET([@五十音],-1,)=[@五十音],"",COUNTIF([五十音],[@五十音])))
'''
'''If 索引数辞書.Count = 0 Then 索引数辞書 = Nothing
''''Debug.Print Join(索引数辞書.Items, ",")
'''    Debug.Print 索引数辞書.Count 'Join(索引数辞書.Items, ",")
'''    If 索引数辞書 Is Nothing Then
'''        Call 索引数辞書編纂
'''    End If
'''
'''    If InStr(索引数辞書.Item(引数.Value), 引数.Address) Then
'''        索引数取得 = Split(索引数辞書.Item(引数.Value), ",")(1)
'''        索引数辞書.Remove 引数.Value
'''    Else
'''        索引数取得 = ""
'''    End If
'''
''''    索引数辞書 = Nothing
'''
'''End Function

'カスタム関数　索引数取得
Function 索引数取得2() As String

''''''    Dim フィールド As Range
''''''    Set フィールド = Range("売場案内T2OutputQueryTable[五十音]").SpecialCells(xlCellTypeVisible)
''''''    Set フィールド = ActiveSheet.ListObjects(2).AutoFilter.Range.Columns(3).SpecialCells(xlCellTypeVisible) '20220617
''''''    Debug.Print フィールド.Cells.Count
'''''''    =IF(IsHidden([@五十音]),"",IF(OFFSET([@五十音],-1,)=[@五十音],"",COUNTIF([五十音],[@五十音])))
''''''    Call 索引数辞書編纂
''''''Exit Function
''''''
''''''    For Each レコード In フィールド
''''''
''''''        If InStr(索引数辞書.Item(レコード.Value), レコード.Address) Then
''''''            Debug.Print フィールド.Address
'''''''            Split(索引数辞書.Item(引数.Value), ",")(1)
''''''            索引数辞書.Remove 引数.Value
''''''        Else
''''''            索引数取得 = ""
''''''        End If
''''''
''''''    Next
    
'    Debug.Print フィールド.Address
''    Debug.Print 連番 & "v:" & フィールド.SpecialCells(xlCellTypeVisible).Cells(1).Value
'    Debug.Print フィールド.SpecialCells(xlCellTypeVisible).Cells(1).Address
'    Debug.Print フィールド.SpecialCells(xlCellTypeVisible).Cells(2).Offset(-1).Address
'    Debug.Print "─────────────────────────────"
    
'    '最初のセルがデータ領域の先頭か否か
'    If 引数.Row = フィールド.Cells(1).Row Then
'        Debug.Print "1:" & WorksheetFunction.CountIf(Range(フィールド.Address), 引数.Value)
'    Else
''        If 引数.(-1).Value = 引数.Value Then
''            Debug.Print "none"
''        Else
''            Debug.Print "2:" & WorksheetFunction.CountIf(Range(フィールド.Address), 引数.Value)
''        End If
'    End If
    
'    索引数取得2 = ""
    
'
'    Debug.Print フィールド.Cells.Count
'    Debug.Print フィールド.SpecialCells(xlCellTypeVisible).Cells.Count
'    Debug.Print フィールド.Address
'
''''''    If 索引数辞書 Is Nothing Then
''''''    Call 索引数辞書編纂
''''''    End If
''''''    Debug.Print Join(索引数辞書.Items, ",")
'
'    Set 索引数辞書 = Nothing

End Function

VBA Excel 売場案内 範囲選択

Function 売場案内マスター入力項目範囲(Optional 引数 As String) As Range '範囲選択　画面（シート）移動在り

    'リストのシートを指定
    Dim WsListMaster As Worksheet
    Set WsListMaster = Worksheets("売場案内.マスター")
       
    WsListMaster.Activate

    'リストのカレント範囲
    Dim i As Long
    i = Application.WorksheetFunction.Max(WsListMaster.Cells(60000, 1).End(xlUp).Row, WsListMaster.Cells(60000, 2).End(xlUp).Row, WsListMaster.Cells(60000, 3).End(xlUp).Row)
    Dim tbl As Range
    Set tbl = WsListMaster.Range(Cells(1, 1), Cells(i, 3)).CurrentRegion
    'Set tbl = tbl.Resize(i - 2, 7).Offset(2) '入力項目にリサイズ
    Set tbl = tbl.Resize(i - 2, 1).Offset(2) '入力項目の一列目にリサイズ
   
    tbl.Select
    
    If 引数 = "return" Then
        Set 売場案内マスター入力項目範囲 = tbl.SpecialCells(xlCellTypeVisible) '戻り値
    End If

End Function

VBA Excel テーブルの並び替えの判定 sort 有無

For Each Table In Me.ListObjects
    If ListObjects(Table.Name).Sort.SortFields.Count Then
        Debug.Print ListObjects(Table.Name).Sort.SortFields.Count
    End If
Next Table

VBA Excel ウェブサイトを開く URLを開く

Private Sub CommandButton1_Click()
    Call マイクロソフトサポートデータフォームについてをブラウザで開く
End Sub

Function マイクロソフトサポートデータフォームについてをブラウザで開く()

    Dim res As Variant
    res = MsgBox("マイクロソフトのサポートページ" & vbNewLine & vbNewLine & _
    "データ フォームを使用して行を追加、編集、検索、および削除する" & vbNewLine & vbNewLine & _
    "をインターネットブラウザーで表示しますか" & vbNewLine _
    , vbYesNo + vbInformation + vbDefaultButton2, "データフォームについて")
    
    If res = vbYes Then
    
        CreateObject("Shell.Application").ShellExecute "microsoft-edge:https://support.microsoft.com/ja-jp/office/%E3%83%87%E3%83%BC%E3%82%BF-%E3%83%95%E3%82%A9%E3%83%BC%E3%83%A0%E3%82%92%E4%BD%BF%E7%94%A8%E3%81%97%E3%81%A6%E8%A1%8C%E3%82%92%E8%BF%BD%E5%8A%A0-%E7%B7%A8%E9%9B%86-%E6%A4%9C%E7%B4%A2-%E3%81%8A%E3%82%88%E3%81%B3%E5%89%8A%E9%99%A4%E3%81%99%E3%82%8B-17bca0a4-3ba5-444a-983c-a8ce70609374"
    
    End If
    
    If res = vbNo Then
        '終了
    End If

End Function

VBA Excel 文字列の全角、半角、混合を判別する

'全て半角に変換する場合
    Dim strANSI     As String
    Dim myLen       As Integer
    Dim myLenB      As Integer
    Dim strUnicode  As String

    strUnicode = Application.WorksheetFunction.Asc(通路番号情報)

    If strUnicode = "" Then
        通路番号分解 = ""
        Exit Function
    End If

    strANSI = StrConv(strUnicode, vbFromUnicode)

    myLen = Len(strUnicode)
    myLenB = LenB(strANSI)

'    '半角カナを全角カナにコンバート
'    If LenB(StrConv(strUnicode, vbHiragana)) - myLenB > 0 Then
'        'Debug.Print "半角カナが混じっています"
'        strUnicode = 半角カナを全角カナに変える(strUnicode)
'        strANSI = StrConv(strUnicode, vbFromUnicode)
'        myLen = Len(strUnicode)
'        myLenB = LenB(strANSI)
'    End If

    If myLen * 2 = myLenB Then
        'Debug.Print "全角文字だけです"
        通路番号分解 = strUnicode
    ElseIf myLen = myLenB Then
        'Debug.Print "半角文字だけです"
        通路番号分解 = strUnicode
    Else
        'Debug.Print "全角と半角が混じっています"
        If strUnicode Like "[A-Z.a-z 0-9]*" Then
            通路番号分解 = 文字列から英数字以外を削除する(strUnicode)
            Else
            通路番号分解 = strUnicode
        End If
    End If

VBA Excel カタカナだけを判別してwideとnarrowに変換する

カタカナが含まれていれば全角カナに変更する

文字列 = StrConv(文字列, vbWide) 'JIS全角にする
If StrConv(文字列, vbHiragana) <> 文字列 Then
	文字列 = 半角カナを全角カナに変える(StrConv(文字列, vbNarrow))
End If

カタカナが含まれていれば半角カナに変更する

文字列 = StrConv(文字列, vbWide) 'JIS全角にする
If StrConv(文字列, vbHiragana) <> 文字列 Then
	文字列 = 全角カナを半角カナに変える(StrConv(文字列, vbNarrow))
End If

Function 半角カナを全角カナに変える(文字列 As String) As String

    Dim キャラクタ As String
    
    Dim Likeパターン As String
    Dim インクリメント As Integer
    
    Likeパターン = "[ｱｲｳｴｵｶｷｸｹｺｻｼｽｾｿﾀﾁﾂﾃﾄﾅﾆﾇﾈﾉﾊﾋﾌﾍﾎﾏﾐﾑﾒﾓﾔﾕﾖﾗﾘﾙﾚﾛﾜｦﾝｧｨｩｪｫｯｬｭｮﾞﾟｰ]"
    戻り値 = ""
    
    For インクリメント = 1 To Len(文字列)
        キャラクタ = Mid(文字列, インクリメント, 1)
        If キャラクタ Like Likeパターン Then
            戻り値 = 戻り値 & StrConv(キャラクタ, vbWide)
        Else
            戻り値 = 戻り値 & キャラクタ
        End If
    Next
    
    半角カナを全角カナに変える = 戻り値

End Function

Function 全角カナを半角カナに変える(文字列 As String) As String

    Dim キャラクタ As String
    
    Dim Likeパターン As String
    Dim インクリメント As Integer
    
    Likeパターン = "[ｱｲｳｴｵｶｷｸｹｺｻｼｽｾｿﾀﾁﾂﾃﾄﾅﾆﾇﾈﾉﾊﾋﾌﾍﾎﾏﾐﾑﾒﾓﾔﾕﾖﾗﾘﾙﾚﾛﾜｦﾝｧｨｩｪｫｯｬｭｮﾞﾟｰ]"
    戻り値 = ""
    
    For インクリメント = 1 To Len(文字列)
        キャラクタ = Mid(文字列, インクリメント, 1)
        If キャラクタ Like Likeパターン Then
            戻り値 = 戻り値 & キャラクタ
        Else
            戻り値 = 戻り値 & StrConv(キャラクタ, vbWide)
        End If
    Next
    
    全角カナを半角カナに変える = 戻り値

End Function

VBA Excel 条件付き書式のルールをマクロで作成 数式で行を塗りつぶす

条件付き書式のルールをマクロで一気に流し込む

肝は、良い感じのカラーインデックスをルールの数だけ配列に入れる。繰り返しは減算のデクリメントで数式の数値が大きい順番になるように指定。ルールの番号はインクリメントで指定。カラーインデックス配列のアイテム番号はもインクリメントで指定してみた。配色は使い捨てのシートなのでテキトーに選んでる。

• arrColorIndex = Array(34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55)
• For d = UBound(arrColorIndex) To 1 Step -1
• xlExpression, Formula1:="=IF(AND(ISNUMBER($G1),$G1>=" & d * 100 & ")

注意：このマクロは既存のルールを削除するので、テストは　.FormatConditions.Delete　をコメント化してやる

画像シート

マクロはシートモジュールに書いといた（マクロの記録をいじった）

Private Sub 条件付き書式設定()
Dim d As Long
Dim i As Long
i = 1
Dim arrColorIndex As Variant
arrColorIndex = Array(34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55)
    With Me.Range("$A:$H")
        .FormatConditions.Delete
        For d = UBound(arrColorIndex) To 1 Step -1
            .FormatConditions.Add Type:=xlExpression, Formula1:="=IF(AND(ISNUMBER($G1),$G1>=" & d * 100 & "),TRUE,FALSE)"
            With .FormatConditions(i).Borders(xlLeft)
                .LineStyle = xlContinuous
                .ThemeColor = 1
                .TintAndShade = -0.249946592608417
                .Weight = xlThin
            End With
            With .FormatConditions(i).Borders(xlRight)
                .LineStyle = xlContinuous
                .ThemeColor = 1
                .TintAndShade = -0.249946592608417
                .Weight = xlThin
            End With
            With .FormatConditions(i).Borders(xlTop)
                .LineStyle = xlContinuous
                .ThemeColor = 1
                .TintAndShade = -0.249946592608417
                .Weight = xlThin
            End With
            With .FormatConditions(i).Borders(xlBottom)
                .LineStyle = xlContinuous
                .ThemeColor = 1
                .TintAndShade = -0.249946592608417
                .Weight = xlThin
            End With
            With .FormatConditions(i).Interior
                .PatternColorIndex = xlAutomatic
                .ColorIndex = arrColorIndex(d)
                .TintAndShade = 0.599981688894314
            End With
            i = i + 1
        Next
    End With
End Sub

画像ルール

画像ルール書式

VBA ユーザー定義関数 Split(文字列,区切り値,取り出す配列番号)

'カスタム関数　Split(文字列,区切り値,取り出す配列番号)
Function hSeparate(ByRef str As String, ByRef sep As String, Optional ByRef lmt As String) As Variant
    Dim v As Variant
    If lmt Then
    v = Split(str, sep)(lmt)
    Else
    v = Split(str, sep)
    End If
    hSeparate = v
End Function

エクセルVBA カタカナをひらがなにする

StrConv(strUnicode, vbHiragana)

Office TANAKA - Excel VBA関数[StrConv]

通路番号分解 文字列が半角、全角、混在かを判断する

=IF(LEN(ASC(D3))=LENB(ASC(D3)),ASC(D3),文字列から英数字以外を削除する(D3))

'カスタム関数　通路番号を分解する
'=IF(LEN(ASC(D3))=LENB(ASC(D3)),ASC(D3),文字列から英数字以外を削除する(D3))
'=IF(LEN(ASC(C3))=LENB(ASC(C3)),ASC(C3),IF(LEN(ASC(C3))*2=LENB(ASC(C3)),ASC(C3),文字列から英数字以外を削除する(C3)))
Function 通路番号分解(通路番号情報 As String) As String

    Dim strANSI     As String
    Dim myLen       As Integer
    Dim myLenB      As Integer
    Dim strUnicode  As String
    
    strUnicode = 通路番号情報
    
    strANSI = StrConv(strUnicode, vbFromUnicode)
    
    myLen = Len(strUnicode)
    myLenB = LenB(strANSI)
    
    If myLen * 2 = myLenB Then
        Debug.Print "全角文字だけです"
        通路番号分解 = Application.WorksheetFunction.JIS(通路番号情報)
    ElseIf myLen = myLenB Then
        Debug.Print "半角文字だけです"
        通路番号分解 = Application.WorksheetFunction.Asc(通路番号情報)
    Else
        Debug.Print "全角と半角が混じっています"
        通路番号分解 = 文字列から英数字以外を削除する(通路番号情報)
    End If
    
End Function

'カスタム関数　文字列から英数字以外を削除する(セル)　文字列から英数字以外を削除する
Function 文字列から英数字以外を削除する(文字列 As String) As String

    Dim 戻り値 As String
    Dim キャラクタ As String
    
    Dim Likeパターン As String
    Dim インクリメント As Integer
    
    Likeパターン = "[A-Z.a-z 0-9]"
    戻り値 = ""
    
    For インクリメント = 1 To Len(文字列)
        キャラクタ = Mid(文字列, インクリメント, 1)
        If キャラクタ Like Likeパターン Then
            戻り値 = 戻り値 & キャラクタ
        End If
    Next
    
    文字列から英数字以外を削除する = 戻り値
    
End Function

Excel VBA を学ぶなら moug モーグ | 即効テクニック | 文字列が半角、全角、混在かを判断する

VBA 文字列から英数字以外を削除する

=IF(LEN(ASC(D3))=LENB(ASC(D3)),ASC(D3),文字列から英数字以外を削除する(D3))

'カスタム関数　文字列から英数字以外を削除する(セル)　文字列から英数字以外を削除する
Function 文字列から英数字以外を削除する(文字列 As String) As String

    Dim 戻り値 As String
    Dim キャラクタ As String
    
    Dim Likeパターン As String
    Dim インクリメント As Integer
    
    Likeパターン = "[A-Z.a-z 0-9]"
    戻り値 = ""
    
    For インクリメント = 1 To Len(文字列)
        キャラクタ = Mid(文字列, インクリメント, 1)
        If キャラクタ Like Likeパターン Then
            戻り値 = 戻り値 & キャラクタ
        End If
    Next
    
    文字列から英数字以外を削除する = 戻り値
    
End Function

連想配列でルックアップな方法 背景色を抽出

Sub aaa()

'***** 部門.マスター *****

    Dim 部門辞書 As Object
    Set 部門辞書 = CreateObject("Scripting.Dictionary")
    
    For Each セル In range("B2:G2") 'range("部門識別子")
        部門辞書.Add セル.Value, セル.Interior.Color
    Next
    
    Debug.Print 部門識別カラー("HO")

End Sub

VBA 選択範囲の任意の列のRange(R1C1)を取得

Debug.Print ConvertToLetter(Selection.Column) & Selection.Row & ":" & _ConvertToLetter(Selection.Column) & Selection.Rows(Selection.Rows.Count).Row
        
Debug.Print Range(Cells(Selection.Row, 2), Cells(Selection.Rows(Selection.Rows.Count).Row, 2)).Address
        
Debug.Print Selection.Columns(2).Address

WindowDOM vba html

リンク

【2017年1月版】Microsoft Edgeを操作するVBAマクロ(DOM編) | 初心者備忘録

↑

WindowDOM vba html - 検索

vba FindWindow

ウインドウ一覧のクラス名とキャプション名を取得する()

WindowsAPIを用いてウインドウの一覧表を作成するVBAコード | VBA・GAS・Pythonで仕事を楽しく効率化

↑

vba FindWindow - 検索

'ウインドウハンドルを取得する
Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

'ウインドウが可視かどうかを取得する
Declare Function IsWindowVisible Lib "user32" _
(ByVal hWnd As Long) As Long

'ウインドウのキャプションタイトルを取得する
Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

'ウインドウのクラス名を取得する
Declare Function GetClassName Lib "user32" Alias "GetClassNameA" _
(ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long

'取得中のウインドウの次または前のウインドウハンドルを取得する
Declare Function GetNextWindow Lib "user32" Alias "GetWindow" _
(ByVal hWnd As Long, ByVal wFlag As Long) As Long

Const GW_HWNDLAST = 1
Const GW_HWNDNEXT = 2

Sub ウインドウ一覧のクラス名とキャプション名を取得する()

Dim i As Long
i = 1

Dim strClassName As String * 100
Dim strCaption As String * 80

Dim hWnd As Long
hWnd = FindWindow(vbNullString, vbNullString) '引数を両方ともvbNullStringにして1つめのウインドウを取得する

Do
If IsWindowVisible(hWnd) Then
GetWindowText hWnd, strCaption, Len(strCaption)
GetClassName hWnd, strClassName, Len(strClassName)

Cells(i, 1).Value = strClassName
Cells(i, 2).Value = strCaption

'Cells(i, 1).Value = Left(strClassName, InStr(strClassName, vbNullChar) ? 1)
'Cells(i, 2).Value = Left(strCaption, InStr(strCaption, vbNullChar) ? 1)

i = Application.WorksheetFunction.Max(Cells(60000, 1).End(xlUp).Row, Cells(60000, 2).End(xlUp).Row, Cells(60000, 3).End(xlUp).Row) + 1

End If

hWnd = GetNextWindow(hWnd, GW_HWNDNEXT)

Loop Until hWnd = GetNextWindow(hWnd, GW_HWNDLAST)

End Sub

VBAでWindowsAPIを用いてウインドウを取得する手順について | VBA・GAS・Pythonで仕事を楽しく効率化

↑

ウインドウのキャプション名・クラス名の一覧表を作成するVBA - 検索

vba エディターの設定 コードの表示色をデフォルトに戻す

VBAエディタのコード表示色

デフォルトの設定値はこちら

古いExcelのスクショですが、

最新のExcelも変わらず同じ

最近の表示色の記録

配置表メモ

配置表旧コード

古い要約の表示［GUI_配置表初期化（コード）］

'要約旧設定///コンフィグ設定欄は非表示
'        Summary = .Item(1).Value '要約（配置番号）
'        Summary = Summary & Worksheets("コンフィグ").Range("コンフィグ_配置表配置番号接尾辞")
'        reg.Pattern = Worksheets("コンフィグ").Range("コンフィグ_配置表配置番号要約非表示")
'        If reg.test(.Item(1).Value) Then
'            Summary = 配置番号から配置名を返す(target)
'        Else
'            Summary = Summary & 配置番号から配置名を返す(target)
'        End If
'        Summary = Summary & " " & MLDIMarrCurrentTaskbarRangeAndFamilyName(1) '要約（氏名）
'///要約旧設定

Function 配置番号から配置名を返す(target As Range) As String '要約旧設定

    If Not IsNumeric(target.Item(1).Value) Then Exit Function

    Dim reg As Object '正規表現オブジェクト作成
    Set reg = CreateObject("VBScript.RegExp")
    reg.Pattern = Worksheets("コンフィグ").Range("コンフィグ_配置表配置名要約非表示文字")

    Dim myCnt As Long
    myCnt = 1
    Do While myCnt <= Range("配置表_範囲カラーピッカー").Count
        Set target = target.Offset(0, 1)
        If Not IsNumeric(target.Value) Then
            If Not reg.test(target.Value) Then 配置番号から配置名を返す = target.Value
            Exit Function
        End If
        myCnt = myCnt + 1
    Loop

End Function

タスクバーの初期色塗りの指定［GUI_配置表初期化（コード）］

'    Dim arrFixed As Variant
'    arrFixed = Split(Worksheets("コンフィグ").Range("コンフィグ_配置表配置固定者"), ",")
'    myStyle = 配置固定スタイル指定コンフィグ指定値(arrFixed, arrName(UBound(arrName))) 'arrName(UBound(arrName))は勤務計画の行番号　配列の最後を表示
'★★★

Function 配置固定スタイル指定コンフィグ指定値(arrFixed As Variant, targetRow As Variant) As Variant '２．要約表示形式

    Dim styleName As Variant
    styleName = ".初期化タスクバー"
    
    Dim reg As Object '正規表現オブジェクト作成
    Set reg = CreateObject("VBScript.RegExp")

    For Each myFixed In arrFixed
    
        reg.Pattern = Split(myFixed, ":")(1)
        If reg.test(targetRow) Then
            styleName = Split(myFixed, ":")(0)
        End If
    
    Next
    
    配置固定スタイル指定コンフィグ指定値 = styleName

End Function

vba 結合されたセルの列を隠す

sub セルの名前から列を非表示(myRange As Range)

'    Dim myRange As Range
'    Set myRange = ActiveCell
'    Set myRange = ActiveSheet.Range("名前")

If myRange.MergeCells Then '結合を検証
    
        '結合されている
    
'        Debug.Print myRange.MergeArea.Address
        
        For Each cell In myRange.MergeArea
        
            Columns(cell.Column).Hidden = True
        
        Next
        
    Else
    
        '結合されていない
        
        Columns(cell.Column).Hidden = True
    
    End If

End sub

VBA 正規表現 複数の文字列の繰り返し パターン

    Dim v As Variant
    With CreateObject("VBScript.RegExp")    '正規表現を利用する為のオブジェクトを作成
        .Pattern = "^(\d{1,2}r((\d{1})|(\d{1}(15|30|45|00)))(,|$|, )?)+$"   '文字列パターンを設定
         v = .test(Str.Value) '結果を格納
         Debug.Print v
    End With

vbaで正規表現

参考サイト

【VBA入門】正規表現で文字列を抽出、置換する方法(RegExp) | 侍エンジニアブログ

 

Sub macro1()
    'RegExpオブジェクトの作成
    Dim reg As Object
    Set reg = CreateObject("VBScript.RegExp")
    
    '正規表現の指定
    With reg
        .Pattern = "[0-9]"      'パターンを指定
        .IgnoreCase = False     '大文字と小文字を区別するか(False)、しないか(True)
        .Global = True          '文字列全体を検索するか(True)、しないか(False)
    End With
    
    Dim str1 As String, str2 As String
    str1 = "東京1大阪2名古屋3"
    str2 = reg.Replace(str1, ",") '指定した正規表現を第2引数の区切り文字に置換
    
    MsgBox str2
End Sub

参考サイト

【VBA】正規表現を使用して検索や置換を行う | 自恃ろぐ-jizilog.com-

Sub Sample2()

'正規表現を使用して文字列を検索する

'＊＊Executeメソッド＊＊

 

  Dim Re As Object

  Dim Mc As Object

  Dim msg As String

  Dim i As Long

   

  '正規表現を利用する為のRegExpオブジェクトを作成

  Set Re = CreateObject("VBScript.RegExp")

   

  With Re

    '正規表現パターンの設定

    '[A-Z,a-z,0-9]で全てのアルファベットと0～9範囲の数値

    '「+」で直前に指定した文字の繰り返しを表す

    '[.][o][m]で「.com」という文字を表す

    'この指定で「.com」で終わる文字列という意味になる

    .Pattern = "[A-Z,a-z,0-9]+[.][o][m]"

     

    '複数マッチを有効

    .Global = True

     

    'セルA1に入力された文字列に対して検索を実行する

    Set Mc = .Execute(Cells(1, 1).Value)

  End With

   

  With Mc

    '対象文字の有無を判定

    If .Count > 0 Then

        For i = 0 To .Count - 1

           '対象文字「有り」の場合、文字を取得

           msg = msg & i + 1 & "番目の文字列：" & _

           .Item(i).Value & vbLf

        Next

     Else

        '対象文字「なし」の場合の文字列

        msg = "該当なし"

    End If

  End With

   

  'メッセージボックスの表示

  If msg = "該当なし" Then

      MsgBox msg, vbCritical

    Else

      MsgBox msg, vbInformation

  End If

   

End Sub

参考サイト

Office TANAKA - Excel VBA Tips[正規表現によるマッチング]

RegExpオブジェクトのプロパティとメソッド

Patternプロパティ	正規表現で使用するパターンを設定します。.*や[A-Z]、(田中|鈴木)などの文字列です。
IgnoreCaseプロパティ	大文字と小文字を区別しないときにTrueを設定します。デフォルトはFalseです。
Globalプロパティ	検索対象の文字列内で、文字列全体を検索するにはTrueを設定します。デフォルトではFalseです。
Testメソッド	正規表現によるマッチングを行います。パターンと一致した場合はTrueを返します。
Replaceメソッド	検索文字列の中で正規表現によるマッチングを行い、成功するとそのマッチした部分を置換文字列と置き換えます。
Executeメソッド	Testメソッドはマッチングが成功したかどうかをTrue/Falseで返します。Executeメソッドは、マッチングの結果をMatchesコレクションとして返します。MatchesコレクションはMatchオブジェクトの集合です。

MatchesコレクションはExecuteメソッドによって返されるコレクションです。Matchesコレクションには0個以上のMatchオブジェクトが含まれます。つまり、Executeメソッドの結果返ってきたMatchesコレクションにMatchオブジェクトが存在しなかったら、マッチングは失敗したということです。

Matchesコレクションのプロパティとメソッド

Countプロパティ	Matchesコレクション内でMatchオブジェクトの個数を返します。これを調べるとマッチングの成功/失敗がわかります。
Itemプロパティ	いわゆる一般的なコレクションのItemプロパティです。普通はMatches(1)のようにアクセスするので使うことはないでしょう。

Matchオブジェクトのプロパティとメソッド

FirstIndexプロパティ	最初にマッチングに成功した位置を返します。文字列の先頭は0から始まります。
Lengthプロパティ	マッチした文字列の長さを返します。
Valueプロパティ	マッチした文字列を返します。

主なメタ文字とエスケープシーケンス

title	title
^	文字列の先頭
$	文字列の末尾
\n	改行
.	改行を除く任意の1文字
*	直前のパターンの0回以上の繰り返し
+	直前のパターンの1回以上の繰り返し
?	直前のパターンが0回または1回現れる
\d	任意の数値
\D	任意の数値以外の文字
\s	任意のスペース文字
\S	任意のスペース以外の文字
()	パターンのグループ化
|	パターンの論理和
[]	キャラクタクラス