VBA 備忘録

Option Explicit
'★★★★★Windows★★★★★★★★★★★★★★★★★★★★★★★★★★★
'◆*******************************************
'起動時の処理
'********************************************
Private Declare Function GetUserName Lib "ADVAPI32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, ByRef nSize As Long) As Long

Private Const MAX_PATH As Long = 255

'◆*******************************************
'Windows のログインユーザー名を取得する
'戻り値：ユーザID
'********************************************
Private Function GetLoginUserName() As String
    On Error GoTo err
    
    Dim sBuffer         As String
    Dim Full_Path       As String
    sBuffer = String$(MAX_PATH, vbNullChar)
    
    If CBool(GetUserName(sBuffer, MAX_PATH) > 0) Then
       GetLoginUserName = Left$(sBuffer, InStr(sBufzafer, vbNullChar) - 1)
    End If

Err_exit:
    Exit Function
err:
    GetLoginUserName = 0
    Resume Err_exit
End Function

Sub test1()
    Dim UserName        As String
    UserName = Application.UserName
    MsgBox UserName
End Sub

Sub Sample()
  Dim obj As Object
  Set obj = CreateObject("WScript.Network")
 
  MsgBox "ユーザー名： " & obj.UserName & vbCrLf _
          & "コンピュータ名： " & obj.ComputerName
          
 
  Set obj = Nothing
End Sub


Sub Test()
    Dim cnt As Long
    cnt = 0
    'ヘッダーの編集
    Dim MyRow As Long
    MyRow = 1
    Cells(MyRow, 1).Value = "フォルダ名"
    Cells(MyRow, 2).Value = "最終更新日時"
    Cells(MyRow, 3).Value = "サイズ（Byte）"
    Cells(MyRow, 4).Value = "読み取り専用"
    Cells(MyRow, 5).Value = "隠しファイル"
    Call Get_FolderObject("T:\FV-All", MyRow)
End Sub

Sub Sample3(Path As String, cnt As Long)
    On Error Resume Next
    Dim buf         As String
    Dim f           As Object
    buf = Dir(Path & "\*.*")
    
    Do While buf <> ""
        cnt = cnt + 1
        Cells(cnt, 1) = buf
        buf = Dir()
    Loop
    
    With CreateObject("Scripting.FileSystemObject")
        For Each f In .GetFolder(Path).SubFolders
            Call Sample3(f.Path, cnt)
        Next f
    End With
End Sub

'****************************************************
'フォルダ配下の一覧と各プロパティを書き出す
'****************************************************
Sub Get_FolderObject(MyPat)
    Dim fso             As Object
    Dim subFolderObj    As Object
    Dim folderObj       As Object
    Dim myFolder        As String
    Dim MyRow           As Long

    Set fso = CreateObject("Scripting.FileSystemObject")
    myFolder = "oya\child\"      '"." はカレントフォルダを意味します。

    'フォルダオブジェクトの取得
    Set folderObj = fso.GetFolder(myFolder)

'    'ヘッダーの編集
'    myRow = 1
'    Cells(myRow, 1).Value = "フォルダ名"
'    Cells(myRow, 2).Value = "最終更新日時"
'    Cells(myRow, 3).Value = "サイズ（Byte）"
'    Cells(myRow, 4).Value = "読み取り専用"
'    Cells(myRow, 5).Value = "隠しファイル"
    On Error Resume Next
    
    For Each subFolderObj In folderObj.SubFolders
        MyRow = MyRow + 1
        
        With subFolderObj
            Cells(MyRow, 1).Value = .Name
            '自動的に書式が変更されるのを防ぐため、先頭に"'"を付与
            Cells(MyRow, 2).Value = "'" & .DateLastModified
            Cells(MyRow, 3).Value = .Size

'            '読み取り専用属性チェック
'            If .Attributes And 1 Then
'                Cells(myRow, 4).Value = "○"
'            Else
'                Cells(myRow, 4).Value = "×"
'            End If
'
'            '隠しファイル属性チェック
'            If .Attributes And 2 Then
'                Cells(myRow, 5).Value = "○"
'            Else
'                Cells(myRow, 5).Value = "×"
'            End If
        End With
    Next

    '使用済みセル範囲のセル幅を自動調整
    ActiveSheet.UsedRange.Columns.AutoFit

    'オブジェクト変数のクリア
    Set fso = Nothing
    Set subFolderObj = Nothing
    Set folderObj = Nothing
    
End Sub

'****************************************************************
'機能定義名 ：Make_Folder
'機能説明   ：個人用フォルダ作成
'引数       ：
'戻り値     ：
'作成       ：PTRM(2018/12/21)
'****************************************************************
Function Make_Folder(BaseFld As String, NewFldNm As String) As Boolean
    Make_Folder = True
    
    Dim FolderPath      As String
    Dim fso             As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
     
    FolderPath = BaseFld & "\" & NewFldNm
     
    If fso.FolderExists(FolderPath) = False Then
        '存在しなければフォルダを作成
        fso.CreateFolder (FolderPath)
    Else
        Make_Folder = False
    End If

End Function

'★★★★★WorkBook★★★★★★★★★★★★★★★★★★★★★★★★★★★
Option Explicit

' ワークブックを閉じる前のイベント(キャンセル可)
Private Sub Workbook_BeforeClose(Cancel As Boolean)
     If MsgBox("Workbook_BeforeCloseイベントが発生しました。" & vbCr & _
         "キャンセルしますか？", vbInformation + vbYesNo) = vbYes Then
         Cancel = True
     End If
End Sub

' ワークブックを保存する前のイベント(キャンセル可)
'Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'     If MsgBox("Workbook_BeforeSaveイベントが発生しました。" & vbCr & _
'         "キャンセルしますか？", vbInformation + vbYesNo) = vbYes Then
'         Cancel = True
'     End If
'End Sub

' ワークブックを開く時のイベント
Private Sub workbook_open()
     ActiveWindow.ScrollRow = 1
     MsgBox "Workbook_Openイベントが発生しました。"
End Sub

' シートを切り替えるイベント
Private Sub Workbook_SheetActivate(ByVal SH As Object)
     MsgBox "Workbook_SheetActivateイベントが発生しました。" & vbCr & _
         "W" & SH.Name & "です。"
End Sub

' ウィンドウを切り替えるイベント(自ブックが手前)
Private Sub Workbook_WindowActivate(ByVal Wn As Window)
     MsgBox "Workbook_WindowActivateイベントが発生しました。"
End Sub

' ウィンドウを切り替えるイベント(自ブックが裏)
Private Sub Workbook_WindowDeactivate(ByVal Wn As Window)
     MsgBox "Workbook_WindowDeactivateイベントが発生しました。"
End Sub

'********************************************
'マクロ アドインメニューをセットする
'IsAdmin  =  True:管理者 False:管理者以外
'********************************************
Private Sub SetMacroMenu()
    Dim IsAdmin As Boolean
    
    IsAdmin = True
'    IsAdmin = False

    With Application.CommandBars(1)
        .Reset
        With .Controls.Add(Type:=msoControlComboBox)
            'メニューリストを追加
            .AddItem "01.Menu1"
            .AddItem "02.Menu2"
            .AddItem "03.Menu3"

            '以下管理者メニュー
            If IsAdmin = False Then GoTo skip
                .AddItem "09.AdminMenu1"
skip:
            .OnAction = "DoMacro"   'アクション名
            .Text = "マクロの選択"  '表示テキスト
            .Width = 600            '幅
            
        End With
    End With
End Sub

'**************************************************************
'マクロアドインメニューを選択したときの処理
'**************************************************************
Public Sub DoMacro()
     With Application.CommandBars(1).Controls
        Select Case Left(.Item(.Count).Text, 2)
            Case "01"
               'Macro1

            Case "02"
               'Macro2

            Case "03"
                'Macro3
            
            Case "09" '管理者メニュー
               'MacroKanrisha

        End Select
    End With
End Sub

'◆**************************************
'右メニュー追加
'**************************************
Public Sub Add_rClckMenu()
    Dim NewBar        As CommandBarControl
    If Application.CommandBars("Cell").Controls.Item(1).Caption = "選択" Then
        Exit Sub
    End If
    
    'セルで右クリック
    Set NewBar = Application.CommandBars("Cell").Controls.Add(Before:=1)
    With NewBar
        .Caption = "選択"
        .OnAction = "RightClck"
        .BeginGroup = False
    End With
    Set NewBar = Nothing

    'Add 2018/11/12 
    '行番号で右クリック
    Set NewBar = Application.CommandBars("Row").Controls.Add(Before:=1)
    With NewBar
        .Caption = "行挿入(新規)"
        .OnAction = "InsRow_New"
        .BeginGroup = False
    End With
    Set NewBar = Nothing

    Set NewBar = Application.CommandBars("Row").Controls.Add(Before:=2)
    With NewBar
        .Caption = "行挿入(改訂)"
        .OnAction = "InsRow_Kaitei"
        .BeginGroup = False
    End With
    Set NewBar = Nothing

End Sub

'**************************************
'右メニュー削除
'**************************************
Sub Del_rClickMenu()
    On Error Resume Next
    CommandBars("Cell").Controls("選択").Delete
    CommandBars("Row").Controls("行挿入(新規)").Delete
    CommandBars("Row").Controls("行挿入(改訂)").Delete
End Sub

'**************************************
'選択画面表示
'**************************************
Public Sub RightClck()
    Dim WB              As Workbook
    Dim WS              As Worksheet

    Set WB = ActiveWorkbook
    Set WS = WB.Worksheets("Sheet1")

    '処理例
    MsgBox "右クリック"
End Sub

'********************************************************************************
'機能定義名 ：InsRow_New
'機能説明   ：右クリックメニュー 行挿入(新規)　選択時　の処理
'           ：処理例
'引数       ：なし
'戻り値     ：なし
'作成       ：PTRM(2018/11/12)
'********************************************************************************
Function InsRow_New()
    Dim WB              As Workbook
    Dim WS              As Worksheet
    Dim Row_RgtClk      As Long
    
    Set WB = ActiveWorkbook
    Set WS = WB.Worksheets("Sheet1")
    Row_RgtClk = ActiveCell.Row
    
    '処理例
    With WS
        .Rows(Row_RgtClk - 1).Insert Shift:=xlDown  '空白行の挿入
        .Cells(Row_RgtClk - 1, 1) = "新規" & 1      '文字を入れる
        .Rows(Row_RgtClk - 1).Font.Color = vbRed    'フォント色を変更
    End With

End Function

'********************************************************************************
'機能定義名 ：InsRow_Kaitei
'機能説明   ：右クリックメニュー 行挿入(改訂)　選択時　の処理
'           ：処理例
'引数       ：なし
'戻り値     ：なし
'作成       ：PTRM(2018/11/12)
'********************************************************************************
Function InsRow_Kaitei()
    Dim WB              As Workbook
    Dim WS              As Worksheet
    Dim Row_RgtClk      As Long
    
    Set WB = ActiveWorkbook
    Set WS = WB.Worksheets("Sheet1")
    Row_RgtClk = ActiveCell.Row
    
    '処理例
    With WS
        .Rows(Row_RgtClk - 1).Insert Shift:=xlDown      '空白行の挿入
        .Cells(Row_RgtClk - 1, 1) = "改訂" & 1          '文字を入れる
        .Rows(Row_RgtClk - 1).Interior.Color = vbRed    ' 背景色を変更
    End With
        
End Function
'◆****************************************************************◆

'★★★★★Worksheet★★★★★★★★★★★★★★★★★★★★★★★★★★★
Option Explicit

'**************************************************************
'新規ワークシートを追加、名前を変更
'**************************************************************
Sub Set_NewWS(WS_Name As String)
  Worksheets.Add after:=Worksheets(Worksheets.Count)    '一番後ろに追加
  'Worksheets.Add after:=Sheets(2)                      '特定の位置
  
  ActiveSheet.Name = WS_Name                            'シート名を変更
End Sub

'◆******************************************************◆
'シート名を取得1
'2016/7/6　R.M
'********************************************************
Sub Test_Get_SheetName()
    Dim ShtNm(10)   As Variant
    Dim ShtCnt      As Integer
    
    Call Get_SheetName(ShtNm, ShtCnt)
    
    Dim i           As Integer
    Do Until i > UBound(ShtNm)
        Worksheets("Sheet1").Cells(i + 1, 1) = ShtNm(i)
        i = i + 1
    Loop
End Sub

'◆*******************************************************
'シート名を取得2
'2016/7/6　R.M
'********************************************************
Sub Get_SheetName(ShtNm As Variant, ShtCnt As Integer)
    Dim MySht       As Worksheet
    
    For Each MySht In Worksheets
        ShtNm(ShtCnt) = MySht.Name
        ShtCnt = ShtCnt + 1
    Next
End Sub
'◆*******************************************************◆

'**************************************************************
'Worksheet の表示方法
'**************************************************************
Sub Set_View()
    Application.GoTo Cells(1, 1), True      'ウィンドウ枠固定に設定した位置を表示

    ActiveWindow.View = xlPageBreakPreview  '改ページプレビュー
    ActiveWindow.Zoom = 75
    
    ActiveWindow.View = xlNormalView        '標準
    ActiveWindow.Zoom = 100

End Sub

'**************************************************************
'印刷範囲の設定
'**************************************************************
Sub Set_Print()
    ActiveSheet.PageSetup.PrintArea = ""            '印刷範囲のクリア
    ActiveSheet.PageSetup.PrintArea = "$A$1:$c$15"  '特定の範囲の設定
    
    Dim stAdr   As String
    Dim EndRow  As Long
    Dim EndCol  As Long
    
    EndRow = 20
    EndCol = 20
    stAdr = "$A$1:" & Cells(EndRow, EndCol).Address     '可変で設定
    ActiveSheet.PageSetup.PrintArea = stAdr

End Sub

'★★★★★File Open Save★★★★★★★★★★★★★★★★★★★★★★★★★★★
Option Explicit

'機能定義名 ：Open_SelectFolder
'機能説明   ：フォルダを選択するダイアログボックスを開く
'機能補足   ：なし
'引数       ：なし
'戻り値     ：なし
'例外処理   ：なし
'作成       ：(2017/4/14)

'■********************************************************************************
'フォルダを選択するダイアログボックスを開く
'FileDialog
'IN･･･FldNm　(Null)
'Out･･･True/False(キャンセル)
'　PT/R.M
'********************************************************************************
Function Open_SelectFolder1(FldNm As String, RowNum As Long, Col As Long) As Boolean
    Open_SelectFolder = False
    Dim FD          As FileDialog
    Set FD = Application.FileDialog(msoFileDialogFolderPicker)
    
    With FD
        '表示するフォルダを指定
        If Dir(IniFld, vbDirectory) = "" Then
            IniFld = ""
        
        Else
        End If
        
        If .Show = True Then
            FldNm = .SelectedItems(1)
            Open_SelectFolder = True
        End If
    End With
    
    If Open_SelectFolder = False Then
        Exit Function
    Else
        Cells(RowNum, Col) = FldNm
    End If

End Function

'********************************************************************************
'機能定義名 ：Open_SelectFolder
'機能説明   ：フォルダを選択する、ダイアログボックスを開く
'引数       ：FldNm-デフォルトフォルダ
'戻り値     ：True　成功 / False　失敗
'作成       ：(2017/4/14)
'********************************************************************************
Function Open_SelectFolder(FldNm As String) As Boolean
    Open_SelectFolder = False
    Dim FD          As FileDialog
    Set FD = Application.FileDialog(msoFileDialogOpen)
    
    With FD
        With .Filters
            .Clear                                  '「ファイルの種類」をクリア
            If FlType = "Excel" Then
                .Add "Excelブック", "*.xlsm", 1         '「ファイルの種類」を登録
            Else
                .Add "CSV　ファイル", "*.csv", 1
            End If
        End With
        
        '表示するフォルダを指定
        ChDir (FldNm & "\")
        .InitialFileName = FldNm & "\"
        
        If .Show = True Then
            FldNm = .SelectedItems(1)
            Open_SelectFolder = True
        End If
    End With
End Function

'********************************************************************************
'機能定義名 ：OpenWB_Dialg1
'機能説明   ：ファイルを開くダイアログボックスを表示し、指定されたファイルを開く
'補足       ：開かない
'引数       ：FldNm-デフォルトフォルダ
'戻り値     ：True　成功 / False　失敗
'作成       ：(2017/4/14)
'********************************************************************************
Function OpenWB_Dialg1(Optional FldNm As String) As Boolean
    OpenWB_Dialg1 = True
    With Application.FileDialog(msoFileDialogOpen)
        
        With .Filters
            .Clear                                          '「ファイルの種類」をクリア
            .Add "Excelブック", "*.xls; *.xlsx; *.xlsm", 1  '「ファイルの種類」を登録
        End With
        
        .InitialFileName = FldNm    '表示するフォルダを指定
                
        If .Show = True Then        '有効なボタンがクリックされた
            .Execute                '開く
        Else                        '[キャンセル]ボタンがクリック
            OpenWB_Dialg1 = False
        End If
        
    End With
End Function

'********************************************************************************
'機能定義名 ：OpenWB_Dialg2
'機能説明   ：ファイルを開くダイアログボックスを表示し、指定されたファイルを開く
'補足       ：すぐ開く
'引数       ：FldNm-デフォルトフォルダ
'戻り値     ：True　成功 / False　失敗
'作成       ：(2017/4/14)
'********************************************************************************
Function OpenWB_Dialg2(FldNm As String) As Boolean
    OpenWB_Dialg2 = True
    
    FldNm = Application.GetOpenFilename("Excelブック,*.xls; *.xlsx; *.xlsm")
    
    If FldNm = "False" Then
        OpenWB_Dialg2 = False
        Exit Function
    End If
        
    Workbooks.Open FldNm
    ActiveWindow.View = xlNormalView
End Function

'********************************************************************************
'機能定義名 ：CK_OpenWB1
'機能説明   ：ファイルが開いていなければ開いて　WBをセットする
'補足       ：
'引数       ：FldNm-保存されているフォルダ
'           ：FlNm -保存されているファイル名
'戻り値     ：WB   -セットされたWB
'作成       ：(2017/4/14)
'********************************************************************************
Sub CK_OpenWB1(WB As Workbook, FldNm As String, FlNm As String)
    On Error GoTo Err_
    
    Set WB = Workbooks(FlNm)  'Setできれば　開いている
    Exit Sub
    
Err_:
    Workbooks.Open (FldNm & FlNm)
    Set WB = Workbooks(FlNm)
End Sub

'********************************************************************************
'機能定義名 ：CK_OpenWB2
'機能説明   ：同名ファイルが開いていれば閉じるようMessageを表示
'補足       ：
'引数       ：FlNm -ファイル名
'戻り値     ：True 開いていなかった / False　開いていた
'作成       ：(2017/4/14)
'同名ファイルが開いていれば閉じるようMessageを表示
'IN･･･PathNm,FlNm
'Out･･･
'2017/5/23　PT/R.M
'********************************************************************************
Function Ck_OpenWB2(FlNm As String) As Boolean
    Ck_OpenWB2 = False
    On Error GoTo Err_
    
    Dim CkWB    As Workbook
    Set CkWB = Workbooks(FlNm)  'Setできれば　開いている
    
    MsgBox "同名のファイルが開かれています。"
    
    Set CkWB = Nothing
    Exit Function
    
Err_:
    Ck_OpenWB2 = True

End Function

'********************************************************************************
'機能定義名 ：SaveWB
'機能説明   ：ファイルを保存
'補足       ：フォルダ、ファイル名は指定
'引数       ：FldNm-保存するフォルダ
'             FlNm -保存するファイル名
'作成       ：(2017/4/14)
'********************************************************************************
Sub SaveWB(FldNm As String, FlNm As String)

    ChDir FldNm
    If Right(FldNm, 1) <> "\" Then
        FldNm = FldNm & "\"
    End If
    
    ActiveWorkbook.SaveAs Filename:=FldNm & FlNm, _
    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Sub

'********************************************************************************
'機能定義名 ：SaveWB_Dialg
'機能説明   ：ファイルを名前を付けて保存
'補足       ：ダイアログボックス表示
'引数       ：FldNm-保存するフォルダ(デフォルト)
'作成       ：(2017/4/14)
'********************************************************************************
Sub SaveWB_Dialg(FldNm As String)
    Application.Dialogs(xlDialogSaveAs).Show arg1:=FldNm
End Sub

'********************************************************************************
'機能定義名 ：Separate_PathNm1
'機能説明   ：フルパスから　フォルダとファイル名を切り分ける
'参照設定   ：FileSystemObject
'引数       ：PathNm-フルパス
'             FldNm-切り分けられたパス
'           　FlNm -ファイル名
'作成       ：(2017/4/14)
'********************************************************************************
Sub Separate_PathNm1(ByVal PathNm As String, FldNm As String, FlNm As String)
    Dim objFso      As Object
    Set objFso = CreateObject("Scripting.FileSystemObject")
    
    FlNm = objFso.GetFileName(PathNm)
    FldNm = Left(PathNm, Len(PathNm) - Len(FlNm))
    
    Set objFso = Nothing
End Sub

'********************************************************************************
'機能定義名 ：Separate_PathNm2
'機能説明   ：フルパスから　フォルダとファイル名を切り分ける
'補足       ：InstrRev関数で、一番後ろの"\"を取得
'引数       ：PathNm-フルパス
'             FldNm-切り分けられたパス
'           　FlNm -ファイル名
'作成       ：(2017/4/14)
'********************************************************************************
Sub Separate_PathNm2(ByVal PathNm As String, FldNm As String, FlNm As String)
    FlNm = Mid(PathNm, InStrRev(PathNm, "\") + 1)
    FldNm = Left(PathNm, Len(PathNm) - Len(FlNm))
End Sub

'********************************************************************************
'新規ブックを開く
'********************************************************************************
Sub OpenNewWB()
    Dim NewWb As Workbook
    Set NewWb = Workbooks.Add
    NewWb.Worksheets("Sheet1").Select
End Sub

'********************************************************************************
'自ブックの指定
'********************************************************************************
Sub MyBook()
    Dim WB_MyTool   As Workbook
    Dim WS_Base     As Worksheet
    
    Set WB_MyTool = Workbooks(ThisWorkbook.Name)

End Sub

'********************************************************************************
'変更をなかったことにする
'保存しますか？のメッセージを表示せずにClose
'********************************************************************************
Sub s1()
    ActiveWorkbook.Saved = True
    ActiveWorkbook.Close
End Sub

'********************************************************************************
'保存しないでClose
'********************************************************************************
Sub s2()
    ActiveWorkbook.Close SaveChanges:=False 'True＝保存
End Sub

'********************************************************************************
'ファイルの存在チェック
'********************************************************************************
Sub FileCheck()
    Dim FldNm       As String
    Dim FlNm        As String
    FldNm = "T:\OA\データ授受用\"
    FlNm = "abc.xlsx"
    
    If Dir(FldNm & FlNm) = "" Then
        MsgBox "ファイルがありません"
    End If
End Sub

'********************************************************************************
'機能定義名 ：Select_BaseFl_Click
'機能説明   ：前回ファイルの参照
'作成       ：(2020/04/06)
'********************************************************************************
Sub Select_BaseFl_Click()
    Dim DfltFld                     As String
    Dim FldNm                       As String
    Dim FlNm                        As String
    
    'デフォルト指定
    DfltFld = ThisWorkbook.Path
    Call SelectFile(DfltFld, FldNm, FlNm)
        
    If FldNm = "" Or FlNm = "" Then
        MsgBox "ファイルを選択してください。"
    Else
        Range("Fld_Base") = FldNm
        Range("Fl_Base") = FlNm
    End If
    
    Dim WB          As Workbook
    
    Call CK_OpenWB1(WB, FldNm & "\" & FlNm, False)
    If WB.Name = "" Then
        Range("Fld_Base") = ""
        Range("Fl_Base") = ""
        Call Err_Msg(5, FlNm)
        Exit Sub
    End If
    
    Dim SH                          As Worksheet
    Dim WS                          As Worksheet
    Dim MyArea                      As Range
    Dim MyRng                       As Range
    '選択されたファイルが目的のファイルかチェック
    If WS_Srch(WB, WS, SH, "*全項目", MyArea, MyRng, 1, 1, 100, 26, "探すことば", xlWhole) = False Then
        Call Err_Msg(4, FlNm)
        Exit Sub
    End If
    
End Sub

'********************************************************************************
'機能定義名 ：WS_Srch
'機能説明   ：該当のWorksheetに特定の文字列が存在するかチェック
'作成       ：(2020/04/06)
'********************************************************************************
Function WS_Srch(WB As Workbook, WS As Worksheet, SH As Worksheet, ShtName As String, MyArea As Range, MyRng As Range, StRow As Long, StCol As Long, EndRow As Long, EndCol As Long, SrchWd As String, Ptrn As String) As Boolean
    On Error GoTo Err_
    WS_Srch = False '見つからなかったら
    
    For Each SH In WB.Worksheets
        If SH.Name Like ShtName Then
            Set WS = WB.Worksheets(SH.Name)
            
            With WS
                Set MyArea = .Range(.Cells(StRow, StCol), .Cells(EndRow, EndCol))
                Set MyRng = MyArea.Find(SrchWd, LookIn:=xlValues, lookat:=Ptrn, MatchCase:=False, MatchByte:=False)
        
                If Not MyRng Is Nothing Then    '見つかったら
                    WS_Srch = True
                    Exit Function
                Else
                    WS_Srch = False '見つからなかったら
                    Exit Function
                End If

            End With
        
        End If
    Next SH
    Exit Function
    
Err_:
    WS_Srch = False
End Function

'★★★★★Format★★★★★★★★★★★★★★★★★★★★★★★★★★★
Option Explicit

'********************************************************************************
'機能定義名 ：Write_Line
'機能説明   ：対象セルに、罫線を設定
'              全体に実線：外枠　縦線、点線：横線　を引いてから 中罫線を設定
'引数       ：WS, SRow, ERow, SCol, ECol,
'             Intvl, Weight_A, Weight_B
'作成       ：(2017/4/14)
'********************************************************************************
Sub Write_Line(WS, SRow, ERow, SCol, ECol, Intvl, Weight_A, Weight_B)
    With WS
        With Range(.Cells(SRow, SCol), .Cells(ERow, ECol))
            .BorderAround Weight:=Weight_A                          '外枠を実線
            .Borders(xlInsideVertical).Weight = Weight_A            '中・縦　線
        End With
        
        With Range(.Cells(SRow, SCol), .Cells(ERow, ECol))
            .Borders(xlInsideHorizontal).Weight = Weight_B          '中・横　線
        End With
        
        Dim n As Long
        For n = SRow To ERow Step Intvl
            With Range(.Cells(n, SCol), .Cells(n, ECol))
                .Borders(xlEdgeBottom).Weight = Weight_A            '中・横　線
            End With
        Next n
    End With
End Sub


Sub Cell_Format()
'    With WS_FlList
        Columns("A:B").Select
        Selection.NumberFormatLocal = "@"
        With Selection
            .HorizontalAlignment = xlRight
        End With
        
        Columns("A:A").Select
        Selection.NumberFormatLocal = "0000"
        Columns("B:B").Select
        Selection.NumberFormatLocal = "000"
        
        Columns("i:i").Select
        With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
        
'        .Range(.Rows(2), .Rows(EndRow)).Select
        Selection.RowHeight = 15
'    End With
End Sub

'★★★★★Cell★★★★★★★★★★★★★★★★★★★★★★★★★★★

Option Explicit
Public Const Orange         As Long = 39423
Public Const LightOrange    As Long = 10079487
Public Const Yellow         As Long = 65535
Public Const CnstEx         As Long = 3

'********************************************************************************
'最終行を算出
'In･･･WS,ColNum1 Option ColNum2,ColNum3
'Out･･･Get_LastRow
'2016/4/11　PT/R.M
'********************************************************************************
Function Get_LastRow(WS As Worksheet, ColNum1 As Integer, _
                     Optional ColNum2 As Integer, Optional ColNum3 As Integer)
    Dim A As Long
    Dim b As Long
    Dim c As Long
    
    With WS
        A = .Cells(Rows.Count, ColNum1).End(xlUp).Row
        b = .Cells(Rows.Count, ColNum2).End(xlUp).Row
        c = .Cells(Rows.Count, ColNum3).End(xlUp).Row
    End With
    
    Get_LastRow = WorksheetFunction.Max(A, b, c)
            
End Function

'********************************************************
'最終列を算出
'In･･･WS,BaseRow
'Out･･･Get_LastCol
'2016/7/7　PT/R.M
'********************************************************
Function Get_LastCol(WS As Worksheet, BaseRow As Long)

    With WS
        Get_LastCol = .Cells(BaseRow, Columns.Count).End(xlToLeft).Column
    End With
End Function

'********************************************************
'コピー　いろいろな方法
'********************************************************
Sub Data_Copy()
    '普通にCopy&Paste
    Range("A1").Select
    Selection.Copy
    Range("H1").Select
    ActiveSheet.Paste
    
    '数式
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        
    '値
    Selection.PasteSpecial Paste:=xlPasteValues     '①
    
    Range("E3") = Range("A5")                       '②
        
    '書式
    Selection.PasteSpecial Paste:=xlPasteFormats
        
    '入力規則
    Selection.PasteSpecial Paste:=xlPasteValidation
        
    '行列を入れ替える
    Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=True
        
    '罫線を除く全て
    Selection.PasteSpecial Paste:=xlPasteAllExceptBorders
    
    '条件付書式 ’値もコピーされてしまう
    Selection.PasteSpecial Paste:=xlPasteAllMergingConditionalFormats

    'クリップボードにコピー
'    Dim buf     As String
'    Dim CB      As New DataObject
'    Dim Val     As String
'    Val = "hogehoge"
'
'    With CB
'        .SetText Val        '変数のデータをDataObjectに格納する
'        .PutInClipboard     'DataObjectのデータをクリップボードに格納する
'        .GetFromClipboard   'クリップボードからDataObjectにデータを取得する
'        buf = .GetText      'DataObjectのデータを変数に取得する
'    End With
    
    Application.CutCopyMode = False
    Application.GoTo Cells(12, 10), True

End Sub

'********************************************************
'最終行、列取得　いろいろな方法
'********************************************************
Sub LastCell(WS As Worksheet)
    Dim MaxRow  As Long
    Dim MaxCol  As Long
    MaxRow = Rows.Count     '1,048,576(Ver.2007)    65,536(Ver.2003)
    MaxCol = Columns.Count  '16,384(Ver.2007)       256(Ver.2003)
    
    '下方向に最終行を検索する
    MaxRow = Range("A1").End(xlDown).Row
    MaxCol = Range("A1").End(xlToRight).Column
    
    '上方向に最終行を検索する
    MaxRow = Range("A65536").End(xlUp).Row          '(Ver.2003)
    MaxCol = Range("IV1").End(xlToLeft).Column      ' IV1=256列(Ver.2003)
    
    '上方向に最終行を検索する
    MaxRow = Cells(Rows.Count, 1).End(xlUp).Row
    MaxCol = Cells(1, Columns.Count).End(xlToLeft).Column
    
    '使用済みの最終セルの選択 （SpecialCells）      '削除済みの行・列も含む(保存後は、含まれない)
    With Range("A1").SpecialCells(xlLastCell)       '書式付空白セル　含む
        MaxRow = .Row
        MaxCol = .Column
    End With
    
    '使用済みの最終セルの選択 （UsedRange）         '左端、上行にデータがなかった場合、減算される
    With ActiveSheet.UsedRange                      'B2:E10 に値が入っている場合　10行10列でなく9行9列
        MaxRow = .Rows.Count
        MaxCol = .Columns.Count
    End With
    
    '使用済みの最終セルの選択（改） （UsedRange）   '書式付空白セル　含む
    With ActiveSheet.UsedRange
        MaxRow = .Rows(.Rows.Count).Row
        MaxCol = .Columns(.Columns.Count).Column
    End With
    
    '書式付きセルを除外する （UsedRange）
    With WS.UsedRange
        MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
        MaxCol = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
    End With
    
    '非表示になっている行を表示
    Cells.Select
    Selection.EntireRow.Hidden = False
    
    'Mergeされたセルの場合
    Dim Row As Long
    Dim ColNum1 As Long
    Row = Cells(Rows.Count, ColNum1).End(xlUp).Row

    If Row >= 1 And Cells(Row, ColNum1).MergeCells Then
        With Cells(Row, ColNum1).MergeArea
            Row = Row + .Rows.Count - 1
        End With
    End If

End Sub

'********************************************************
'セルアドレスを取得　行方向
'In･･･WS,BaseRow, LastRow, StCol, SrchWord
'Out･･･Get_RowAdrs
'2016/7/6　PT/R.M
'********************************************************
Function Get_RowAdrs(WS As Worksheet, BaseRow As Long, LastRow As Long, StCol As Integer, SrchWord As String)
    Dim nRow    As Long     'loop用
    
    With WS
        For nRow = BaseRow + 1 To LastRow
            If .Cells(nRow, StCol).Value = SrchWord Then
               Get_RowAdrs = nRow
               Exit For
            End If
        Next nRow
    End With
End Function

'***********************************************************
'機能定義名 ：Find_Range
'機能説明   ：範囲の中で該当の文字列を検索
'引数       ：ptrn = xlwhole,xlpart
'戻り値     ：
'作成       ：(2019/5/24)
'********************************************************
Function Find_Range(WS As Worksheet, MyArea As Range, MyRng As Range, SrchWd1 As Variant, Ptrn As String) As Boolean
    Find_Range = True
    
    With WS
        Set MyRng = MyArea.Rows.Find(SrchWd1, lookat:=Ptrn, MatchCase:=fale, MatchByte:=False)
        
        If Not MyRng Is Nothing Then
        Else
            Find_Range = False
        End If
        
    End With
End Function

'*****************************************************
'機能定義名 ：FindRange
'機能説明   ：範囲の中で該当の文字列をすべて検索
'引数       ：
'戻り値     ：
'作成       ：(2019/5/24)
'********************************************************
Function FindRange(WS As Worksheet, MyArea As Range, MyRng As Range, SrchWd1 As String, Ptrn As String, AftrTxt As String) As Boolean
    FindRange = True
    Dim Rng1St      As Range
    
    With WS
        Set MyRng = MyArea.Rows.Find(SrchWd1, lookat:=xlPart)
        
        If Not MyRng Is Nothing Then
            Set Rng1St = MyRng
            
            Do
                Set MyRng = Rows.FindNext(MyRng)
                Call Wrt_ChangeName(WS, MyRng.Row, MyRng.Column, Ptrn, AftrTxt)
            Loop While MyRng.Address <> Rng1St.Address
        End If
        
    End With
End Function

'◆********************************************************************************
'機能定義名 ：CK_SrchWd
'機能説明   ：該当のWorksheetに特定の文字列が存在するかチェック
'作成       ：(2020/04/06)
'********************************************************************************
Function CK_SrchWd(WS As Worksheet, MyArea As Range, MyRng As Range, StRow As Long, StCol As Long, EndRow As Long, EndCol As Long, SrchWd As String, Ptrn As String) As Boolean
    On Error GoTo Err_
    CK_SrchWd = False                             '見つからなかったら
    
    With WS
        .Activate
        Set MyArea = .Range(.Cells(StRow, StCol), .Cells(EndRow, EndCol))
        Set MyRng = MyArea.Find(SrchWd, LookIn:=xlValues, lookat:=Ptrn, MatchCase:=False, MatchByte:=False)

        If Not MyRng Is Nothing Then        '見つかったら
            CK_SrchWd = True
        Else
            CK_SrchWd = False               '見つからなかったら
        End If
    End With
    
    Exit Function
Err_:
    CK_SrchWd = False
End Function

'◆********************************************************
'セルアドレスを取得
'Out･･･RowNum,ColNum
'2016/7/6　R.M
'********************************************************
Function Get_Address2(BaseRow, StCol, EndCol, SrchWord1)
    Cells(BaseRow, StCol).Select
    
    Dim n As Integer
    For n = StCol To EndCol
        If Cells(BaseRow, n) = SrchWord1 Then
            Get_Address2 = n
            Exit For
        End If
    Next n
End Function

'◆********************************************************
'セルアドレスを取得
'Out･･･RowNum,ColNum,Cntry
'In･･･SrchWord1(VID),SchWord2(SysNm)
'2016/7/6　R.M
'********************************************************
Function Get_Address3(BaseRow, LastRow, StCol, EndCol, SrchWord1, SrchWord2, RowNum, ColNum, Cntry)
    Dim nRow    As Long     'loop用
    Dim nCol    As Integer  'loop用
    
    For nRow = BaseRow To LastRow
        If Val(Cells(nRow, "C")) = SrchWord1 Then
           RowNum = nRow
           
            For nCol = StCol To EndCol
                If Cells(Range("SysName").Row - 2, nCol) = SrchWord2 Then
                    ColNum = nCol
                    Exit For
                End If
            Next nCol
            Exit For
        End If
    Next nRow
    
    If RowNum > 0 Then
        Cntry = Cells(RowNum, "A")
    Else
        Cntry = 0
    End If
    
    If ColNum = 0 Then
        Cntry = 0
    End If
End Function

'********************************************************
'機能定義名 ：Like_SelectCase
'機能説明   ：SelectCase　の場合の　あいまい条件
'引数       ：cV
'戻り値     ：cV
'作成       ：(2019/6/12)
'********************************************************
Sub Like_SelectCase()
    Dim st  As String
    st = "あいうえお依頼書かきくけ"

    Select Case True

        Case st Like "*依頼書*"
        
        Case st Like "*ABC資料*"
        
    End Select
End Sub

'********************************************************
'機能定義名 ：BetweenAnd_SelectCase
'機能説明   ：SelectCase　の場合の範囲条件
'引数       ：cV
'戻り値     ：cV
'作成       ：(2019/6/12)
'********************************************************
Sub BetweenAnd_SelectCase()
    Dim age  As Long
    age = 11

    Select Case age
        Case Is < 7, Is > 18

        Case 7 To 12
        
        Case 13 To 15
        
        Case 16 To 18
        
        Case Else
        
    End Select

End Sub

Sub t()
    Dim Bfr As Variant
    Dim Afr As Variant
    Dim TTlRow As Long
    TTlRow = 111

'    Bfr = "5"
'    Afr = ChngNumAlph(Bfr)
    Range("B111") = "=COUNTA(" & ChngNumAlph(5) & TTlRow + 1 & ":" & ChngNumAlph(8) & TTlRow + 1 & ")"
End Sub

'********************************************************
'機能定義名 ：ChngNumAlph
'機能説明   ：セルアドレスを数値からアルファベット/アルファベットから数値に変換
'引数       ：cV
'戻り値     ：cV
'作成       ：(2019/6/12)
'********************************************************
Function ChngNumAlph(cV As Variant) As Variant
    Dim Alph    As String
    
    If IsNumeric(cV) = True Then
        Alph = Cells(1, cV).Address(RowAbsolute:=False, ColumnAbsolute:=False)
        ChngNumAlph = Left(Alph, Len(Alph) - 1)
    Else
        ChngNumAlph = Range(cV & "1").Column
    End If
End Function

'********************************************
'ひとつも型の導入がなかった国名を列削除
'********************************************
Sub Delete_Column(WS As Worksheet, A_Kata_Col, AA1_DaiCDRow As Long)
    Dim ColNum          As Long
    Dim BfrColNum       As Long
    Dim StrColAdrs      As String
    Dim DelColAdrs      As String
    Dim Posi            As Long
    
    With WS
        buff = ""
        ColNum = A_Kata_Col + 1
        ' 大分類列の終了までループ
        Do While RTrim(.Cells(AA1_DaiCDRow, ColNum)) = AA1_D_CODE
            If (.Cells(1, ColNum) <> "1") Then
                
                StrColAdrs = Split(Cells(, ColNum).Address, "$")(1)
                
                If DelColAdrs = "" Then
                    DelColAdrs = StrColAdrs & ":" & StrColAdrs
                
                ElseIf BfrColNum + 1 = ColNum Then
                    Posi = InStrRev(DelColAdrs, ":") - 1
                    DelColAdrs = Left(DelColAdrs, Posi) & ":" & StrColAdrs
                Else
                    DelColAdrs = DelColAdrs & "," & StrColAdrs & ":" & StrColAdrs
                End If
                
                BfrColNum = ColNum
            End If
            
            ColNum = ColNum + 1
            
            If Len(DelColAdrs) > 200 Then
                .Range(DelColAdrs).Delete               ' 列削除（リリース版）
                DelColAdrs = ""
            End If
        Loop
        
        ' 非導入国列を削除（非表示）
        If DelColAdrs <> "" Then
            .Range(DelColAdrs).Delete                   ' 列削除（リリース版）
        End If
    End With
End Sub

'****************************************************************************
'x行挿入
'****************************************************************************
Sub InsRow(WS As Worksheet, TrgtRow1 As Long, TrgtRow2 As Long)
    With WS
        .Rows(TrgtRow).Insert Shift:=xlDown     '1行
        .Range(.Rows(TrgtRow1), .Rows(TrgtRow2)).Insert Shift:=xlDown   '複数行
        
        .Range(.Rows(TrgtRow1), .Rows(TrgtRow2)).Select
        Selection.Interior.ColorIndex = xlNone                                      '背景色を設定しない
        .Rows(TrgtRow).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow   '下の行の書式を適用するコード
        .Rows(TrgtRow).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove    '上の行の書式を適用するコード

    End With
End Sub

'****************************************************************************
'固定された行の直下が表示されるように設定
'****************************************************************************
Sub Sample2()
    Dim i As Long
    For i = 1 To 1000
        If Cells(i, 1) = "もうぐ 太郎" Then
            Application.GoTo Cells(i, 1), True
            Exit For
        End If
    Next i
End Sub

Sub Test()
    Columns(1).Select   ' 1 列目 A
    Columns("A").Select ' 1 列目 A
    Columns(3).Select   ' 3 列目 C
    Range("B2").EntireColumn.Select
    Range("B:C").Select                  ' B ～ C 列目を取得
    Range(Columns(2), Columns(3)).Select ' B ～ C 列目を取得
    Range("D:D").Select                  ' D 列目を取得
    
    Range("A:A, C:C, E:F").Select
    Columns(44).Insert
    Columns("CV").Clear

'    Range(.Columns(9), .Columns(10)).Select
End Sub

'********************************************
'機能定義名 ：Delete_Rows
'機能説明   ：一括行削除
'引数       ：
'戻り値     ：
'作成       ：PTRM(2017/5/9)
'********************************************
Sub Delete_Rows(WS As Worksheet, StRow As Long, LastRow As Long, MstrAdrs As Adrs_Master)
    Dim Row         As Long
    Dim Row_Cel
    Dim BeforeRow   As Long
    Dim Posi        As Integer
    Dim buff
    Dim TmpRow      As String
    Dim DelRow      As String

    With WS
        .Activate
        buff = ""
        Row_Cel = ""
        
        For Row = LastRow To StRow Step -1
            If .Cells(Row, MstrAdrs.Slct) = 1 Then
                GoTo NxtRow
            End If
            
            If TmpRow = "" Then
                BeforeRow = Row
                TmpRow = Row & ":" & BeforeRow
            
            ElseIf BeforeRow - 1 = Row Then
                Posi = InStrRev(TmpRow, ":")
                TmpRow = Left(TmpRow, Posi) & Row
                BeforeRow = Row
                
            Else
                DelRow = TmpRow
                BeforeRow = Row
                TmpRow = TmpRow & "," & Row & ":" & BeforeRow
                
                If Len(DelRow) >= 240 Then
                    Call Delete_CollectRow(WS, DelRow)
                    TmpRow = ""
                    DelRow = ""
                End If
            End If
NxtRow:
        Next Row
        
        DelRow = TmpRow
        If DelRow <> "" Then
            Call Delete_CollectRow(WS, DelRow)
        End If

    End With
End Sub

'★★★★★Data★★★★★★★★★★★★★★★★★★★★★★★★★★★
Option Explicit

'**************************************************************
'定義された名前の一覧を作成する()
'**************************************************************
Sub Name_Define()
    Dim WS          As Worksheet
    Dim dName       As Name
    Dim i           As Long
    
    Set WS = Worksheets("Sheet1")
    Range("A1").Value = "名前"
    Range("B1").Value = "参照範囲"
    Range("C1").Value = "範囲"

    i = 2
    With WS
        For Each dName In Names
            .Cells(i, 1).Value = dName.Name
            .Cells(i, 2).Value = "'" & dName.RefersTo
            .Cells(i, 3).Value = dName.Parent.Name
             '定義した名前の場所を取得
'            .Cells(i, 4).Value = Range("SysName").Row
'            .Cells(i, 5).Value = Range("SysName").Column
'            .Cells(i, 6).Value = Range("Year").Column
            i = i + 1
        Next dName
    End With
End Sub

'**************************************************************
'定義した名前が　＃REF になっている名前　を削除
'**************************************************************
Sub Delete_Names()
    Dim nm As Name
    On Error Resume Next  ' エラーを無視。
    
    For Each nm In ActiveWorkbook.Names
        If InStr(nm.Value, "#REF") > 0 Or _
            InStr(nm.Value, "\") > 0 Then
            nm.Delete
        End If
    Next nm
End Sub

'**********************************************
'改行文字　等の置き換え
'FindTxt1　があれば AfterTxt1に置き換える
'FindTxt2からFindTxt4は、任意
'**********************************************
Function TxtReplace(Before, AfterTxt1 As String, FindTxt1 As String, Optional FindTxt2 As String, Optional FindTxt3 As String, Optional FindTxt4 As String) As String
    TxtReplace = Replace(Before, FindTxt1, AfterTxt1)
    TxtReplace = Replace(TxtReplace, FindTxt2, AfterTxt1)
    TxtReplace = Replace(TxtReplace, FindTxt3, AfterTxt1)
    TxtReplace = Replace(TxtReplace, FindTxt4, AfterTxt1)
End Function

Sub test_Sort()
    Dim WS          As Worksheet
    Dim AreaRng     As Range
    Dim KeyRng1     As Range
    Dim KeyRng2     As Range
    Dim KeyRng3     As Range
    
    Set WS = ActiveWorkbook.Worksheets(2)
    With WS
    
    End With
    
    Set KeyRng1 = Columns(1)
    Set KeyRng2 = Columns(2)
    Set KeyRng3 = Columns(3)
    
    Call Sort_Data(WS, AreaRng, KeyRng1, KeyRng2, KeyRng3)

End Sub

'****************************************************************
'機能定義名 ：SortCustom
'機能説明   ：集計表シートの順でクリコミ一覧をソートするために
'          　 CustomOderを設定しソート
'引数       ：なし
'戻り値     ：なし
'作成       ：PTRM(2019/11/18)
'****************************************************************
Sub SortCustom(glbWS_Count As Worksheet, glbWS_Prgrs As Worksheet, CustomOder As String, cStRow As Long, cEndRow As Long, WrtStRow As Long, WrtEndRow As Long, pCol As pLstCol, Optional Mishori As String)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With glbWS_Count
        .Activate
        Dim Row         As Long
        '行の上から下まで、文書タイプをつなげていく
        For Row = cStRow To cEndRow
            If CustomOder = "" Then
                CustomOder = .Cells(Row, 2)
            Else
                CustomOder = CustomOder & ", " & .Cells(Row, 2)
            End If
        Next Row
     End With
     
     With glbWS_Prgrs
        .Activate
        Dim MyArea          As Range
        Dim KeyRng(3)       As Range
        Dim CustomOder2     As String
        Set MyArea = .Range(.Cells(WrtStRow, 1), .Cells(WrtEndRow, pCol.AA_Step))
        Set KeyRng(0) = Columns(pCol.TypeDoc)
        
        If Mishori = "mishori" Then '再集計の時
            Set KeyRng(1) = Columns(pCol.InCharge)
            Set KeyRng(2) = Columns(pCol.Step)
            CustomOder2 = ""
            
        Else
            Set KeyRng(1) = Columns(pCol.Project)
            Set KeyRng(2) = Columns(pCol.RcveML)
            Set KeyRng(3) = Columns(pCol.Step)
            CustomOder2 = "未処理, リマインダ, 参考情報, PW, 処理不要(B資料のみ), 処理不要, 回答済"
        
        End If
        
        If Mishori = "Receive" Then
            Call CstmSort_Data2(glbWS_Prgrs, MyArea, KeyRng, CustomOder, CustomOder2)
        Else
            Call CstmSort_Data(glbWS_Prgrs, MyArea, KeyRng, CustomOder, CustomOder2)
        End If
    End With
End Sub

'********************************************************
'機能定義名 ：CstmSort_Data
'機能説明   ：ソート CustomOder
'引数       ：
'戻り値     ：
'作成       ：PTRM(2019/11/18)
'********************************************************
Sub CstmSort_Data(glbWS_Prgrs As Worksheet, AreaRng As Range, KeyRng, CstmOrder As String, CstmOrder2 As String)

    With glbWS_Prgrs
        .Activate
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=KeyRng(0), SortOn:=xlSortOnValues, _
                                 Order:=xlAscending, CustomOrder:=""" & CstmOrder & """, DataOption:=xlSortNormal    '数値に見えるものは数値として"
                                 
            .SortFields.Add Key:=KeyRng(1), SortOn:=xlSortOnValues, _
                                 Order:=xlAscending, CustomOrder:=""" & CstmOrder2 & """, DataOption:=xlSortNormal
                                 
            .SortFields.Add Key:=KeyRng(2), SortOn:=xlSortOnValues, _
                                 Order:=xlAscending, CustomOrder:=""" & CstmOrder2 & """, DataOption:=xlSortNormal
            .SetRange AreaRng
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom        'xlTopToBottom/xlLeftToRight
            .SortMethod = xlStroke
            .Apply
            .SortFields.Clear
        End With
    End With
End Sub

'********************************************************
'機能定義名 ：CstmSort_Data
'機能説明   ：ソート CustomOder
'引数       ：
'戻り値     ：
'作成       ：PTRM(2019/11/18)
'********************************************************
Sub CstmSort_Data2(glbWS_Prgrs As Worksheet, AreaRng As Range, KeyRng, CstmOrder As String, CstmOrder2 As String)

    With glbWS_Prgrs
        .Activate
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=KeyRng(0), SortOn:=xlSortOnValues, _
                                 Order:=xlAscending, CustomOrder:="" & CstmOrder & "", DataOption:=xlSortNormal    '文書の種類  '数値に見えるものは数値として
                                 
            .SortFields.Add Key:=KeyRng(1), SortOn:=xlSortOnValues, _
                                 Order:=xlAscending, DataOption:=xlSortNormal                                           '車種・機能
                                 
            .SortFields.Add Key:=KeyRng(2), SortOn:=xlSortOnValues, _
                                 Order:=xlAscending, DataOption:=xlSortNormal                                           '受信日時
            
            .SortFields.Add Key:=KeyRng(3), SortOn:=xlSortOnValues, _
                                 Order:=xlAscending, CustomOrder:="" & CstmOrder2 & "", DataOption:=xlSortNormal        '処理状況

            .SetRange AreaRng
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom        'xlTopToBottom/xlLeftToRight
            .SortMethod = xlStroke
            .Apply
            .SortFields.Clear
        End With
    End With
End Sub

'********************************************************
'データのソート
'2017/8/31　PT/R.M
'********************************************************
Sub Sort_Data(WS As Worksheet, AreaRng As Range, KeyRng1 As Range, KeyRng2 As Range, KeyRng3 As Range)

    With WS
        AreaRng.Select
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=KeyRng1, SortOn:=xlSortOnValues, _
                             Order:=xlAscending, DataOption:=xlSortTextAsNumbers    '数値とテキスト形式の数値を分けて
                             
        .Sort.SortFields.Add Key:=KeyRng2, SortOn:=xlSortOnValues, _
                             Order:=xlAscending, DataOption:=xlSortNormal           '数値に見えるものは数値として
                             
        .Sort.SortFields.Add Key:=KeyRng3, SortOn:=xlSortOnValues, _
                             Order:=xlAscending, DataOption:=xlSortNormal

        With WS.Sort
            .SetRange AreaRng
'            .SetRange Range("A1:T450")
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom        'xlTopToBottom/xlLeftToRight
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
End Sub

'********************************************************
'オートフィルタがあれば解除
'********************************************************
Sub Auto_Filter()
    Dim MyRange     As AutoFilter
    Dim WS          As Worksheet
    
    Set WS = Worksheets("Sheet1")
    Set MyRange = WS.AutoFilter
    
    If Not MyRange Is Nothing Then
        If WS.AutoFilter.FilterMode Then
            Range("A1").AutoFilter
            Exit Sub
        End If
    End If
End Sub

'********************************************************
'列表示のグループ化解除
'非表示セルの表示
'********************************************************
Sub Macro4()

    ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=3
    Cells.Select
    Selection.EntireColumn.Hidden = False
End Sub


Sub Shape_Button()
    With Worksheets("Sheet1").Shapes("ButtonEngine")
       .OnAction = "Macro4"    'False
       .Fill.ForeColor.RGB = RGB(192, 192, 192)
        .TextFrame.Characters.Font.Color = RGB(192, 192, 192)
    End With
End Sub

'クイックソート
Sub QuickSort(a_Ar(), Optional iFirst As Integer = 0, Optional iLast As Integer = -1)
    Dim iLeft                   As Integer      ' 左ループカウンタ
    Dim iRight                  As Integer      ' 右ループカウンタ
    Dim sMedian                 As Variant      ' 中央値
    Dim Tmp                                     ' 配列移動用バッファ
    
    ' ソート終了位置省略時は配列要素数を設定
    If (iLast = -1) Then
        iLast = UBound(a_Ar)
    End If
   
    sMedian = a_Ar(Int((iFirst + iLast) / 2))   ' 中央値を取得
    iLeft = iFirst
    iRight = iLast
    
    Do                                          ' 中央値の左側をループ
        Do                                      ' 配列の左側から中央値より大きい値を探す
            If (a_Ar(iLeft) >= sMedian) Then
                Exit Do
            End If
            
            iLeft = iLeft + 1                   ' 左側を１つ右にずらす
        Loop
        
        Do                                      ' 中央値の右側をループ
            If (sMedian >= a_Ar(iRight)) Then   ' 配列の右側から中央値より大きい値を探す
                Exit Do
            End If
            
            iRight = iRight - 1                 ' 右側を１つ左にずらす
        Loop
        
        If (iLeft >= iRight) Then               ' 左側の方が大きければここで処理終了
            Exit Do
        End If
        
        Tmp = a_Ar(iLeft)                       ' 右側の方が大きい場合は、左右を入れ替える
        a_Ar(iLeft) = a_Ar(iRight)
        a_Ar(iRight) = Tmp
        
        iLeft = iLeft + 1                       ' 左側を１つ右にずらす
        iRight = iRight - 1                     ' 右側を１つ左にずらす
    Loop
    
    ' 中央値の左側を再帰でクイックソート
    If (iFirst < iLeft - 1) Then
        Call QuickSort(a_Ar, iFirst, iLeft - 1)
    End If
    
    ' 中央値の右側を再帰でクイックソート
    If (iRight + 1 < iLast) Then
        Call QuickSort(a_Ar, iRight + 1, iLast)
    End If
    
End Sub

★★★★RegExp★★★★★★★★★★★★★★★★★★★★★★★★★★★
'★Option Explicit

Sub Test()
    Dim Design As String
    Design = "Ａ１２３４－１ＳＥアｎｇ"
    
    If Len(Design) >= 12 Then
        If InStr(1, Design, "（") >= 1 Or InStr(1, Design, "(") >= 1 Then
            Design = Left(Design, InStr(1, Design, "（") - 1)
            Design = Left(Design, InStr(1, Design, "(") - 1)
        End If
        
        Dim i           As Long
        Dim Design2     As String
        Dim Temp        As String
        Dim Result      As String
        
        For i = 1 To Len(Design)
            Temp = Mid(Design, i, 1)
            Call FindJpRegExp(Temp, Result)
            
            If Result <> "" Then
               Exit For
            Else
                Design2 = Design2 & Temp
            End If
        Next i
        
        Design = Design2
    End If
    
    Dim Pattern
    Pattern = "[0-9][0-9][0-9][A-Z]"
    If RegExpPrjct(Subject, Pattern, Prjct) = True Then
        Get_Prjct = True
        Exit Function           '●●●B
    End If
Dic_:
    MsgBox Design
End Sub

'****************************************************************
'機能定義名 ：FindJpRegExp
'機能説明   ：日本語を除く
'引数       ：
'戻り値     ：
'作成       ：PTRM(2019/10/15)
'****************************************************************
Function FindJpRegExp(s, Result)
    Dim Reg     As New RegExp       '正規表現クラスオブジェクト
    
    '検索条件＝日本語を抽出
    Reg.Pattern = "[ぁ-んァ-ヶ一-龠〃々〆〇｡-ﾟ]"
    '文字列の最後まで検索する
    Reg.Global = True
    '指定セルの日本語を空文字に置き換える
    Result = Reg.Replace(s, "")
End Function

Sub test2()
    Dim Reg         As New RegExp
    Dim st          As String
    Dim ck          As String
    Dim Matches     As Variant
    Dim Match       As Variant
    
    With Reg '数字3桁とアルファベット1文字
'        .Pattern = "[0-9][0-9][0-9][A-Z]"
'        .Pattern = "(\d)(\d)(\d)([A-Z])"
        .Pattern = "(\d){3}([A-Z])"
        .IgnoreCase = False 'false:大文字小文字を区別する／True：区別しない '
        .Global = True
    End With
    
    st = "ab111cd1e234Efgh5678Ijkl9012"
    ' st = "【審123e議依頼】T222AB2040G 種類543X ｄｄｄｄｄ"
    Set Matches = Reg.Execute(st)
    
    For Each Match In Matches
        ck = Match.FirstIndex
        MsgBox Mid(st, ck + 1, 4)
    Next Match

End Sub

'★★★★★UserTeigi★★★★★★★★★★★★★★★★★★★★★★★★★★★
Option Explicit

'******************************************
'ユーザー定義型の作成
'作成：PT/R.M  2017/9/22
'******************************************
Public Type Head5_Type
    Group   As String
    HIN5    As String
End Type

'******************************************
'ユーザー定義型の作成
'作成：PT/R.M  2017/9/22
'******************************************
Public Type Temp_Type
    Group   As String
    HIN5    As String
End Type

'*******************************************
'ユーザーフォームのデータを並び替え
'提出シート作成オプション
'GrNo→5桁品番
'作成：PT/R.M  2017/9/22
'*******************************************
Public Sub BtnSort()
    Dim i
    Dim j
    Dim Head5Hin()      As Head5_Type   'ユーザー定義型
    Dim Tmp(0)          As Temp_Type    'ユーザー定義型
    
    'ユーザーフォームのリストボックスの値を取得
    ReDim Head5Hin(WS_OP.ListBox1.ListCount - 1)
    For i = 0 To WS_OP.ListBox1.ListCount - 1
        Head5Hin(i).Group = Val(Mid(WS_OP.ListBox1.List(i, 0), 2, 3))
        Head5Hin(i).HIN5 = Format(Val(WS_OP.ListBox1.List(i, 1)), "00000")
    Next i

    'GrNoだけをキーに昇順に並び替え
    For i = LBound(Head5Hin) To UBound(Head5Hin)
        For j = UBound(Head5Hin) To i Step -1
            If Val(Head5Hin(i).Group) > Val(Head5Hin(j).Group) Then
                Tmp(0).Group = Head5Hin(i).Group
                Tmp(0).HIN5 = Head5Hin(i).HIN5
                
                Head5Hin(i).Group = Head5Hin(j).Group
                Head5Hin(i).HIN5 = Head5Hin(j).HIN5
                
                Head5Hin(j).Group = Tmp(0).Group
                Head5Hin(j).HIN5 = Tmp(0).HIN5
            End If
        Next j
    Next i
    
    '同じGrNoの中だけで5桁品番を昇順に並び替え
    For i = LBound(Head5Hin) To UBound(Head5Hin)
        For j = i + 1 To UBound(Head5Hin)
            If Val(Head5Hin(i).Group) = Val(Head5Hin(j).Group) Then
                 If Val(Head5Hin(i).HIN5) > Val(Head5Hin(j).HIN5) Then
                     Tmp(0).Group = Head5Hin(i).Group
                     Tmp(0).HIN5 = Head5Hin(i).HIN5
                     
                     Head5Hin(i).Group = Head5Hin(j).Group
                     Head5Hin(i).HIN5 = Head5Hin(j).HIN5
                     
                     Head5Hin(j).Group = Tmp(0).Group
                     Head5Hin(j).HIN5 = Tmp(0).HIN5
                 End If
            End If
            
            If j >= 9 Then Exit For
        Next j
        
        If i >= 9 Then Exit For
    Next i
    
    '並び替えた値をリストボックスに表示
    WS_OP.ListBox1.Clear
    For i = 0 To UBound(Head5Hin)
        WS_OP.ListBox1.AddItem
        WS_OP.ListBox1.List(i, 0) = "G" & Head5Hin(i).Group
        WS_OP.ListBox1.List(i, 1) = Head5Hin(i).HIN5
        j = j + 1
    Next i
End Sub

'♪♪♪♪♪♪♪♪♪♪ユーザー定義♪♪♪♪♪♪♪♪♪♪
'****************************************************************
'機能定義名 ：pLstCol
'機能説明   ：
'参加者リスト
'****************************************************************
Type pLstCol
    Number                  As Long
    AtndrNm                 As Long
    Respons                 As Long
    CmpnyNm                 As Long
End Type
    
'****************************************************************
'機能定義名 ：dLstCol
'機能説明   ：
'Distributor
'****************************************************************
Type dLstCol
    Cntry                   As Long
    JCntry                  As Long
    CmpnyNm                 As Long
    ShortNm                 As Long
End Type

'****************************************************************
'機能定義名 ：Visa
'機能説明   ：
'Visa申請用　データ
'****************************************************************
Type Visa
    AtndrNm                 As String
    Respons                 As String
    CmpnyNm                 As String
End Type

'★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
'****************************************************************
'機能定義名 ：Set_ColAdrs
'機能説明   ：Public 変数に　列位置を設定
'列の追加/削除・・・メンテ必要
'作成       ：PTRM(2018/12/20)
'****************************************************************
'Sub Set_ColAdrs(WS As Worksheet, pCol As pLstCol)
'    With WS
'        pCol.Number = .Range("Number_").Column
'        pCol.AtndrNm = .Range("ParticipantName").Column
'        pCol.Respons = .Range("RspnsblCntry").Column
'        pCol.CmpnyNm = .Range("Distributor").Column
'    End With
'End Sub

'****************************************************************
'機能定義名 ：Set_ColAdrsPrsn
'機能説明   ：Public 変数に　列位置を設定
'列の追加/削除：メンテ必要
'作成       ：PTRM(2018/12/20)
'****************************************************************
'Sub Set_ColAdrsPrsn(dCol As dLstCol)
'    With pWS_DistList
'        dCol.Cntry = .Range("Country").Column               'B
'        dCol.JCntry = .Range("J_Country").Column            'C
'        dCol.ShortNm = .Range("ShortName").Column           'E
'        dCol.CmpnyNm = .Range("CmpnyName").Column           'F
'    End With
'End Sub

'★★★★★Err★★★★★★★★★★★★★★★★★★★★★★★★★★★
Option Explicit

'********************************************************************************
'機能定義名 ：Err_Msg
'機能説明   ：ErrNoごとに　メッセージを表示
'引数       ：ErrNo-他のモジュールで捉えたエラー番号
'作成       ：(2017/4/14)
'********************************************************************************
Sub Err_Msg(ErrNo As Long, Optional ErrNm As String)
    Dim ErrSt       As String
    
    Select Case ErrNo
        Case 1
           ErrSt = "ファイルが選択されていません。"
        
        Case 2
           ErrSt = "シートがありません。" & vbCr & _
                   ErrNm
        Case 9
        
    End Select
    
    MsgBox ErrSt
    
    MsgBox "パソナテックまでお問合せください｡　" & Step & vbCrLf & _
        "エラー番号　　：" & err.Number & vbCrLf & _
        "エラー種類　　：" & err.Description, vbExclamation
End Sub

'◆********************************************************************************
'機能定義名 ：Err_Message
'機能説明   ：エラーメッセージの検索とJP/Eng　メッセージの切替
'引数       ：
'戻り値     ：True　成功 / False　失敗
'作成       ：(2019/5/24)
'********************************************************************************
Function Err_Message(WS_Msg As Worksheet, MyArea As Range, MyRng As Range, ErrNum As String, Col As Long, EndRow As Long, Optional PlusMsg As String, Optional Flg As String) As Boolean
    Err_Message = True
    With WS_Msg
        Set MyArea = WS_Msg.Range(.Cells(1, 1), .Cells(EndRow, 4))
        Set MyRng = MyArea.Rows.Find(ErrNum, lookat:=xlWhole)
    End With
    
    Dim Msg     As Integer
    
    If Flg = "" Then    '通常のエラーメッセージ
        MsgBox WS_Msg.Cells(MyRng.Row, Col), vbCritical, WS_Msg.Cells(, Col)
        
    ElseIf Flg = "OKCancel" Then             'Ok/Cancel　選択する場合
        Msg = MsgBox(WS_Msg.Cells(MyRng.Row, Col) & PlusMsg, vbOKCancel, WS_Msg.Cells(, Col))
        If Msg = vbCancel Then  'Change 2019/6/7
            Err_Message = True
        Else
            Err_Message = False
        End If
    Else
        MsgBox WS_Msg.Cells(MyRng.Row, Col), vbInformation, WS_Msg.Cells(, Col)
    End If
End Function

'★★★★★Array★★★★★★★★★★★★★★★★★★★★★★★★★★★
Option Explicit

'********************************************************************************
'配列が空かどうか調べる
'In･･･varArray  配列
'Out･･･判定結果　　1:配列　0:空の配列　-1:配列じゃない
'2016/7/11　PT/R.M
'********************************************************************************
Function IsArrayEx(varArray As Variant) As Long
    On Error GoTo ERROR_

    If IsArray(varArray) Then
        IsArrayEx = IIf(UBound(varArray) >= 0, 1, 0)
    Else
        IsArrayEx = -1
    End If

    Exit Function

ERROR_:
    If err.Number = 9 Then
        IsArrayEx = 0
    End If
End Function


Sub Sample()
    Dim strArray() As String
    Dim StrAray As String
    
    Select Case IsArrayEx(strArray)
        Case 1
            Debug.Print "strArrayは配列です。"
            
        Case 0
            Debug.Print "strArrayは空の配列です。"
            
        Case -1
            Debug.Print "strArrayは配列ではありません。"
    End Select
End Sub

'配列を消す　erase itm

'★★★★★IE★★★★★★★★★★★★★★★★★★★★★★★★★★★
Option Explicit

'****************************************************************
'機能定義名 ：setElmRefe
'機能説明   ：Web画面の ファイルの参照　ボタンを制御
'引数       ：ObjIE　　 InternetExplorer
'             KeyName   タグ名                  <Img ...>
'             Val       ファイル名(フルパス)    \\tec-hfs\...
'戻り値     ：True　成功 / False　失敗
'作成       ：PTRM(2018/10/3)
'****************************************************************
'Function setElmRefe(ObjIE As InternetExplorer, KeyName As String, Val As String) As Boolean
'    Sleep (500)
'    setElmRefe = True
'
'    'クリップボードにコピー
'    Dim buf     As String
'    Dim CB      As New DataObject
'
'    With CB
'        .SetText Val        '変数のデータをDataObjectに格納する
'        .PutInClipboard     'DataObjectのデータをクリップボードに格納する
'        .GetFromClipboard   'クリップボードからDataObjectにデータを取得する
'        buf = .GetText      'DataObjectのデータを変数に取得する
'    End With
'
'    ObjIE.document.getElementsByName(KeyName)(0).Focus  'タイトル１の空欄にフォーカスを当てる
'
'    Dim cnt         As Long
'    For cnt = 0 To 10
'        Sleep (100)
'        DoEvents
'    Next
'
'    Dim hwnd        As Long
'    SendKeys "{Tab}", True          '参照
'    SendKeys " ", True              'ダイアログを開く
'
'    For cnt = 0 To 10
'        hwnd = FindWindow(vbNullString, "アップロードするファイルの選択")
'        If hwnd = 0 Then
'            Sleep (1000)
'        Else
'            Exit For
'        End If
'    Next cnt
'
'    'hwndが取得できていない=ページを取得できていない
'    If hwnd = 0 Then
'        setElmRefe = False
'        Exit Function
'    End If
'
'    For cnt = 0 To 10
'        Sleep (100)
'        DoEvents
'    Next
'
'    SendKeys "^V", True                 'ファイル名を入力　クリップボードからペースト
'    Sleep (1000)
'    SendKeys "{Tab}{Enter}", True       '開く　ボタンをクリック
'    Exit Function
'
'End Function


'★★★★★Word★★★★★★★★★★★★★★★★★★★★★★★★★★★
Option Explicit

'**************************************
'指定されたフォルダの全Wordからデータを抽出し、一覧表シートに書き込む
'2017/4/20
'**************************************
Sub Make_FlowData()
    Dim WS_Menu     As Worksheet
    Dim WS_Flow     As Worksheet
    Set WS_Menu = Worksheets("Menu")
    Set WS_Flow = Worksheets("FlowChart一覧表")

    Dim FldNm       As String       'Flow　データが入っているフォルダ
    Dim FlNm        As String       'Flow　ファイル
    FldNm = WS_Menu.Cells(4, "E") & "\"
       
    Dim Wd          As Object       'Word　Object
    Set Wd = CreateObject("Word.application")
    
    Dim Txt()       As String       '取得したデータを格納
    Dim LastRow     As Long
    Call Get_LastRow(WS_Flow, LastRow, 1)
    ReDim Txt(LastRow - 1, 2)
    
    Dim n           As Long
    With WS_Flow
        For n = 2 To LastRow
            FlNm = .Cells(n, "A")
            If .Cells(n, "H") = "" Then
                .Cells(n, "G") = "ファイルなし"
                GoTo Next_
            End If
                        
            If .Cells(n, "G") <> "更新なし" Or .Cells(n, "F") = "" Then
                'Word文章を開きデータを取得
                Call Get_WordData(Wd, FldNm & FlNm, Txt, n)
                
                '取得したデータを書き込む
                If InStr(1, Txt(n - 2, 0), "(", vbTextCompare) - 1 >= 1 Then    'データ中に"("　があればその後ろを　System　とみなす
                    .Cells(n, "B") = Left(Txt(n - 2, 0), InStr(1, Txt(n - 2, 0), "(", vbTextCompare) - 1)   'Component
                    .Cells(n, "C") = Mid(Txt(n - 2, 0), InStr(1, Txt(n - 2, 0), "(", vbTextCompare), Len(Txt(n - 2, 0)))    'System
                Else
                    .Cells(n, "B") = Txt(n - 2, 0)  'Component
                    .Cells(n, "C") = ""             'System
                End If
                
                .Cells(n, "D") = Txt(n - 2, 1)      'PCode
                .Cells(n, "E") = Txt(n - 2, 2)      'Type
                Application.StatusBar = n & "/" & LastRow & "処理中"
            End If
Next_:
        Next n
    End With
    
    Call Delete_Txt(WS_Flow, LastRow)
    Application.StatusBar = ""
    Wd.Quit
    Set Wd = Nothing
End Sub

'**************************************
'1ページ目の1個目の表の2行目を３列分取得する
'**************************************
Sub Get_WordData(Wd, FlNm, Txt, n)
    Const wdPrintView = 3
    Const WdTextRectAngle = 0
    Dim Doc     As Object

    Set Doc = Wd.Documents.Open(FlNm, ReadOnly:=True)
   
    With Doc.Bookmarks("\Page").Range.Tables
        If .Count = 0 Then Exit Sub
        Txt(n - 2, 0) = .Item(1).cell(2, 1)
        Txt(n - 2, 1) = .Item(1).cell(2, 2)
        
        If .Item(1).cell(2, 3) Like "*/*" Then
            Txt(n - 2, 2) = .Item(1).cell(2, 4)
        Else
            Txt(n - 2, 2) = .Item(1).cell(2, 3)
        End If
    End With
    
    Doc.Close
    Set Doc = Nothing
End Sub

'★★★★★AddPAGENo★★★★★★★★★★★★★★★★★★★★★★★★★★★
Option Explicit

'******************************************
'ページ振り作業
'******************************************
Sub AddPageNum()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error GoTo 0
    
    Dim WB_My       As Workbook
    Dim WS_Menu     As Worksheet
    Dim WS_FlList   As Worksheet
    
    Dim myWord      As Word.Document
    Set WB_My = Workbooks(ThisWorkbook.Name)
    Set WS_Menu = WB_My.Worksheets("MENU")
    Set WS_FlList = WB_My.Worksheets("FileList")
    
    Dim FldNm       As String
    Dim Fl_Doc       As String
    FldNm = WS_Menu.Range("Ref_Fld_WData")
    
    Dim FlCnt       As Long

    'ページ番号の指定前に、セクション分けのページ番号の分断を排除しなければならない。
    Dim LstRow      As Long
    Dim i           As Long         'ログ書き出し用
    Dim Tmp         As String
    
    LstRow = Get_LastRow1(WS_FlList, 3)
    If LstRow = 1 Then
        MsgBox "FileList　シートにデータがありません" & vbCr & _
               "確認して下さい。"
        Exit Sub
    End If
    
    Dim fTxt        As String       'Footerのテキスト
    Dim Posi        As Long         '{PAGE}の文字位置
    Dim BfrTxt      As String       '{PAGE}より前の文字
    Dim AftrTxt     As String       '　　　　後の文字
    
    Dim pTxt        As String       '開始ページ番号のテキスト
    Dim TxtPge      As String       'テキストとしてフッターに入れる文字
    Dim Pge         As Long         'カウントアップしていくPage
    
    Dim oWrdApp As New Word.Application
    Set oWrdApp = CreateObject("Word.Application")
    
    With WS_FlList
        For FlCnt = 2 To LstRow
            Application.StatusBar = FlCnt - 1 & "/" & LstRow - 1
            
            If .Cells(FlCnt, 9) = "●" Then
                FldNm = WS_FlList.Cells(FlCnt, 8)
                Fl_Doc = WS_FlList.Cells(FlCnt, 3)  'With ～　ではなく、完全修飾でないと『リモートサーバー･･･』エラー発生
                pTxt = WS_FlList.Cells(FlCnt, 5)
                
                If InStrRev(pTxt, ".") >= 1 Then
                    Posi = InStrRev(pTxt, ".")
                    TxtPge = Left(pTxt, Posi)
                    Pge = Right(pTxt, Len(pTxt) - Posi)
                Else
                    TxtPge = ""
                    Pge = WS_FlList.Cells(FlCnt, 5)
                End If
                
                Documents.Open Filename:=FldNm & "\" & Fl_Doc, Visible:=False
                Set myWord = Documents(Fl_Doc)
'                Set myWord = GetObject(.Cells(FlCnt, 8) & "\" & DocNm)
                
                '全てのセクションの設定を解除
                If WS_FlList.Cells(FlCnt, 7) > 1 Then
                    For i = 2 To WS_FlList.Cells(FlCnt, 7)
                        myWord.Sections(i).Footers(wdHeaderFooterPrimary).PageNumbers.RestartNumberingAtSection = False
                        myWord.Sections(i).Footers(wdHeaderFooterPrimary).LinkToPrevious = True
                    Next i
                End If
                
                myWord.Sections(1).PageSetup.SectionStart = wdSectionContinuous 'セクションの開始位置を「現在の位置」に指定
        
                'ページ開始番号の指定
                '◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆
                '現在のフッターのテキスト部分を取得　例：Page:9.10JTYXB_COMMON_
                'テキストとして　文字を追加　　　　　例：10.0.1.
                '｛Page｝は、数値として　カウントアップ　例：1
                'Page:9.10JTYXB_COMMON_10.0.1.1
                '◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆
                fTxt = myWord.Sections(1).Footers(wdHeaderFooterPrimary).Range.Text
                Posi = InStrRev(fTxt, "COMMON-")
                BfrTxt = Left(fTxt, Posi + 6)
                
                With myWord.Sections(1).Footers(wdHeaderFooterPrimary).Range.Find
                    .Text = BfrTxt
                    
                    With .Replacement
                        .Text = BfrTxt & TxtPge
                    End With
                    
                    .Execute Replace:=wdReplaceAll, Format:=False, MatchWholeWord:=True ',matchcase;=true
                End With
                
                myWord.Sections(1).Footers(wdHeaderFooterPrimary).PageNumbers.RestartNumberingAtSection = True
                myWord.Sections(1).Headers(wdHeaderFooterFirstPage).PageNumbers.StartingNumber = Pge
                myWord.Close SaveChanges:=True
            End If
            
            '初期化
            BfrTxt = ""
            AftrTxt = ""
            TxtPge = ""
            
        Next FlCnt
    End With
    
    Set WS_Menu = Nothing
    Set WS_FlList = Nothing
    Set WB_My = Nothing
    Set myWord = Nothing
    oWrdApp.Quit
    Set oWrdApp = Nothing

    Application.StatusBar = ""
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "ページ番号の書込みが終了しました"
    Exit Sub
    
Msg:
    MsgBox "もう一度同じ操作をしてください"
    
End Sub

'★★★★★Dictionary★★★★★★★★★★★★★★★★★★★★★★★★★★★
Option Explicit
'参照設定　Microsoft Scripting Runtime
'ItmCnt = UBound(DicDivNm.Item(DocType)) + 1

'****************************************
'****************************************
'****************************************
'対策としては objDict.Exists("fuga") でキーを問い合わせることです
'if dic_A("fuga") then      '"fuga" がなかったら　Addされる
'if dic_A.Exists("fuga") then       変数名には注意。プロシージャー外でも似たような変数名があるとAddされる
'    MsgBox "fuga"
'else
'   MsgBox "登録済み"
'end if

'****************************************************************
'機能定義名 ：Make_DicAIL
'機能説明   ：AILファイルから法規のDictionaryを登録
'引数       ：
'戻り値     ：Dic_Master
'作成       ：PTRM(2020/04/09)
'****************************************************************
Sub Make_DicAIL(WS As Worksheet, Dic_AIL As Dictionary, FlNm As String, AILAdrs As Adrs_AIL, MstrAdrs As Adrs_Master)
    Dim Row                 As Long
    Dim Key                 As String
    Dim Itm()               As String
    Dim EndRow              As Long
    Dim Posi                As Long
    Dim ItmCnt              As Long
    Dim Tmp                 As String
    
    With WS
        .Activate
        EndRow = Get_LastRow(WS, 3, AILAdrs.Aprvl_ECE, AILAdrs.Regu_ECE)
        
        For Row = AILAdrs.Row_Ttl + 1 To EndRow
            ReDim Preserve Itm(0)
            Posi = InStr(1, .Cells(Row, AILAdrs.Regu_ECE), "R") - 1
            Key = "R" & Left(.Cells(Row, AILAdrs.Regu_ECE), Posi) '& "_" & Row
            
            If Not Dic_AIL.Exists(Key) Then
                Itm(0) = .Cells(Row, AILAdrs.Aprvl_ECE) & "," & .Cells(Row, AILAdrs.Date_Stmp)
                Dic_AIL.Add Key, Itm
                
            Else
                Itm = Dic_AIL.Item(Key)                     'Keyに登録されているItemを取得
                ItmCnt = UBound(Dic_AIL.Item(Key)) + 1      '配列の要素を追加
                ReDim Preserve Itm(ItmCnt)
                Itm(ItmCnt) = .Cells(Row, AILAdrs.Aprvl_ECE) & "," & .Cells(Row, AILAdrs.Date_Stmp)
                Dic_AIL(Key) = Itm                          '値を変更
            End If
NxtRow:
        Next Row
    End With
End Sub

'****************************************
'Dictionaryに登録　基本１
'****************************************
Sub Dictionary_Set1()
    'Dim DicA As New Dictionary      'でもOK
    Dim DicA        As Dictionary
    Set DicA = New Dictionary
    
    '登録のみ
    DicA.Add "Book", "本"
    DicA.Add "Desk", "机"
    DicA.Add "Chair", "いす"
'    DicA.Add "Book", "書籍"     'Book　は既に登録済みなのでErrorになる
    '値を変更
    DicA("Book") = "書籍"
End Sub

'****************************************
'Dictionaryに登録　基本２
'登録済みKeyはスルー
'****************************************
Sub Dictionary_Set2()
    Dim DicA        As Dictionary
    Set DicA = New Dictionary
    
    '登録済のKeyは　スルー
    Dim i           As Integer
    Dim Key         As String
    Dim Itm         As String
    Dim WB          As Workbook
    Dim WS1         As Worksheet
    Set WB = Workbooks("Book1")
    Set WS1 = WB.Worksheets("Sheet1")
    
    With WS1
        For i = 1 To 4
            Key = .Cells(i, 1).Value
            Itm = .Cells(i, 2).Value
            
            If Not DicA.Exists(Key) Then
                DicA.Add Key, Itm
            End If
        Next i
    End With
End Sub

'****************************************
'Dictionaryに登録　基本３
'Itemを配列で登録
'****************************************
Sub Dictionary_Set3()
    Dim DicA        As Dictionary
    Set DicA = New Dictionary
    
    '登録済のKeyは　スルー
    Dim i           As Integer
    Dim Key         As String
    Dim Itm(2)      As String
    Dim WB          As Workbook
    Dim WS1         As Worksheet
    Set WB = Workbooks("Book1")
    Set WS1 = WB.Worksheets("Sheet1")
    
    With WS1
        For i = 1 To 4
            Key = .Cells(i, 4).Value
            Itm(0) = .Cells(i, 5).Value
            Itm(1) = .Cells(i, 6).Value
            Itm(2) = .Cells(i, 7).Value
            
            If Not DicA.Exists(Key) Then
                DicA.Add Key, Itm
            End If
        Next i
    End With

End Sub

Sub DicSample()
    'Prjct  が関係性にあるかチェック
'    If FindRange(WS_Relation, MyArea, MyRng, Prjct, xlWhole) = True Then
'        Key = WS_Relation.Cells(MyRng.Row, 1).Value         '例:G2
'        '★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
'        '１つのKeyのItemの要素数
'        ItmCnt = UBound(DicSamePj.Item(Key)) + 1            '例:2       0:123B,1:222B,2:333B
'        '★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
'    Else
'        ItmCnt = 0
'    End If
    
    j = 0
    
    Do Until j > ItmCnt
      'あればItemの数だけループ
      'なければ1回のみ上まで探す
        Do Until i > Row - 1
            If DocType = .Cells(i, pCol.TypeDoc) Then
                If Key <> "" Then
                    Itm = DicSamePj.Item(Key)(j)
                Else
                    Itm = Prjct
                End If
                
                If Prjct = Itm Then           '1回目 123B　2回目　222B
                   '書込み処理
                    FlgNum = .Cells(i, pCol.Number)         'その行のNoを取得
                    .Cells(i, pCol.SameCase) = Number       'あったら　その行に　Noを書きこむ
                    .Cells(Row, pCol.SameCase) = FlgNum     'チェックしている側に　旧のNoを書込む
                End If
            End If
            i = i + 1
        Loop
        j = j + 1
    Loop
Nxt:
 End Sub
 
Sub Test()
    Dim WS          As Worksheet
    Dim DaihyoNo    As New Dictionary
    Call Get_Daihinban(WS, DaihyoNo, 1, 10, 100)
End Sub

'******************************************
'選択されたフル品番に含まれる　親品番を取得
'PT/R.M 2017/11/28
'******************************************
Function Get_Daihinban(nWS_Zmn As Worksheet, DaihyoNo As Dictionary, StRow As Long, EndRow As Long, dCnt As Long)
    Dim n       As Long
    Dim buf     As String
    dCnt = 0
    
    With nWS_Zmn
        .Activate
        For n = StRow To EndRow
            If .Cells(n, ColDai) = "" Then GoTo NxtRow
            buf = .Cells(n, ColDai)
            
            If Not DaihyoNo.Exists(buf) Then
                DaihyoNo.Add buf, dCnt
                dCnt = dCnt + 1
            End If
NxtRow:
        Next n
    End With
    
    Dim DaiKeys
    Dim DaiItems
    DaiKeys = DaihyoNo.Keys
    DaiItems = DaihyoNo.Items
End Function

'**********************************************
'型式を辞書に設定
'Key=型式、Item＝国配列(,0)=記号、(,1)=国名
'**********************************************
Sub Get_DnyKoku(WS, dicDnyKK, Cntry, St_RowA As Long, Lst_RowA As Long, Ttl_RowA As Long, St_ColA As Long, Lst_ColA As Long, dKey, dItm)
    Dim Row         As Long
    Dim buf         As String
    Dim i
    
    With WS
        For Row = St_RowA To Lst_RowA
            'DictionaryのItemを配列にする
            Call Get_Country(WS, Cntry, Row, Ttl_RowA, St_ColA, Lst_ColA)
            'Key
            buf = .Cells(Row, St_ColA - 1).Value
            
            If Not dicDnyKK.Exists(buf) Then
                dicDnyKK.Add buf, Cntry
            End If
        Next Row
    End With
    
    dKey = dicDnyKK.Keys()
    dItm = dicDnyKK.Items()
    
End Sub

'**********************************************
'型式を辞書に設定
'Key=型式、Item＝同じ型の行数
'**********************************************
Sub Get_Vari(WS_Vari As Worksheet, dicVari, St_RowV As Long, Lst_RowV As Long, Ttl_ColV As Long, vKey, vItm)
    Dim Tmp     As String
    Dim Row     As Long     'Loop用
    Dim StRow   As Long     '1つの型の最初の行
    Dim buf     As String
    Dim cnt     As Long     '1つの型の行数カウント

    With WS_Vari
        Tmp = .Cells(St_RowV, Ttl_ColV)
        cnt = 1

        For Row = St_RowV To Lst_RowV
            buf = .Cells(Row, Ttl_ColV).Value
            Do While buf = .Cells(Row + cnt, Ttl_ColV)
                cnt = cnt + 1
            Loop
            
            If Not dicVari.Exists(buf) Then
                dicVari.Add buf, cnt
            End If
            Row = Row + cnt - 1
            cnt = 1
        Next Row
    End With
    
    vKey = dicVari.Keys
    vItm = dicVari.Items

End Sub

'**********************************************
'配列に必要な要素数を算出
'**********************************************
Sub Get_Size(dicDnyKK As Dictionary, dicVari As Dictionary, YousoSize As Long, vKey)
    Dim vCnt        As Long     'Vari の行数
    Dim dCnt        As Long     'DnyKKの行数
    Dim RsltClc     As Long     'Vari の行数　×　DnyKKの行数　の掛け算の結果
    Dim Tmp                     'dicDnyKKのItem＝Cntryオブジェを一旦格納
    Dim i           As Long     'dicVariのループ用
    i = 0
    
    Do Until i = dicVari.Count
        vCnt = dicVari(vKey(i))
        Tmp = dicDnyKK(vKey(i)) 'dicDnyKKのItem＝Cntry配列を一旦格納
        dCnt = Tmp(2)           'Cntry配列の2番目を取り出す
        RsltClc = vCnt * dCnt
        YousoSize = YousoSize + RsltClc
        i = i + 1
    Loop
End Sub

'**********************************************
'判例を辞書に設定
'Key=記号、Item＝名称
'**********************************************
Sub Make_Dic(WS As Worksheet, dic As Dictionary, TTlRow As Long, StRow As Long, Col As Long)
    Dim Row         As Long
    Dim buf_Mrk     As String
    Dim buf_Nm      As String
    Dim i
    
    With WS
        For Row = TTlRow + 2 To StRow - 1
            If .Cells(Row, Col) = "" Then Exit For
            buf_Mrk = Left(.Cells(Row, Col), 2)   'Key'空白含む
            buf_Nm = Mid(.Cells(Row, Col), 4, Len(.Cells(Row, Col)) - 3)  'Item
                        
            If Not dic.Exists(buf_Mrk) Then
                dic.Add buf_Mrk, buf_Nm
            End If
        Next Row
    End With
End Sub

'**********************************************
'Dictionaryからループを使ってデータを取得する
'**********************************************
Public Function dic()

     Dim Mydic As New Dictionary
     Dim i As Integer

     Mydic.Add "Book", "本"
     Mydic.Add "Desk", "机"
     Mydic.Add "Chair", "いす"
     
     '★★★★★★★★★★★★★★★★★★★★★★★★★★★
     '値を変更
     Mydic("Book") = "ノート"
     '★★★★★★★★★★★★★★★★★★★★★★★★★★★
     
     Dim Keys()     As Variant
     Dim Items()    As Variant
     Keys() = Mydic.Keys
     Items() = Mydic.Items
     
     Dim Item

    '■「アイテム」を取り出す ※インデックスは0から
    For i = 0 To Mydic.Count - 1
        Debug.Print Mydic.Items(i)
    Next i
    
    '■「キー」を取り出す
    For i = 0 To Mydic.Count - 1
         Debug.Print Mydic.Keys(i)
    Next i

    '■両方同時に取り出す(キー → アイテム)
    Dim Var As Variant
    For Each Var In Mydic
         Debug.Print Var & "," & Mydic.Item(Var) 'book & "," item(book)→　book,本
         Debug.Print Mydic.Item(Var)
    Next Var

    '■アイテムとキーを取り出す(アイテム → キー)
    For i = 0 To Mydic.Count - 1
         Debug.Print Mydic.Items(i)
         Dim st
         st = "Book"
         Debug.Print Mydic(st)
         
         st = "机"
         Debug.Print Mydic.Item(st)
         Debug.Print Mydic.Items(st)
'         Debug.Print Mydic("机") & "のKeyは   " & Mydic(st)
    Next i

End Function

'**********************************************
'Item　を　objectで格納し、取り出す
'**********************************************
Public Sub dicAndObject()

     Dim DicA As New Dictionary
     Dim i As Integer
     Dim obj(1)
     
     obj(0) = "つくえ"
     obj(1) = "Desk"
     DicA.Add "机", obj
     
     obj(0) = "いす"
     obj(1) = "Chair"
     DicA.Add "椅子", obj
     
     obj(0) = "ほん"
     obj(1) = "Book"
     DicA.Add "本", obj
     Dim Keys()     As Variant
     Dim Items()    As Variant
     Keys = DicA.Keys
     Items = DicA.Items
     
    '■「アイテム」を取り出す ※インデックスは0から
    For i = 0 To DicA.Count - 1
        Debug.Print DicA.Items(i)(0)    'obj(i,0)･･･ つくえ,いす,ほん
        Debug.Print DicA.Items(i)(1)    'obj(i,1)･･･ Desk,Chair,Book
    Next i
    
    Debug.Print "************************************************************"
    '■「キー」を取り出す
   For i = 0 To DicA.Count - 1
         Debug.Print "Key :" & DicA.Keys(i)
         Debug.Print "Item(i,0):" & DicA.Items(i)(0)
         Debug.Print "Item(i,1):" & DicA.Items(i)(1)
         Debug.Print "Item(i,0)のKeyは : " & DicA.Keys(i)
         
'         Debug.Print dicA.Key(Items(1)(0))
    Next i

    '■両方同時に取り出す(キー → アイテム)
    Dim Var As Variant
    For Each Var In DicA
         Debug.Print Var & "," & DicA.Item(Var)(0) & "," & DicA.Item(Var)(1)
    Next Var
    
End Sub
'Public dicdic As New Dictionary

Sub d()
    Dim i           As Long
    Dim StKey(4)       As String
    
    For i = 1 To 100
        StKey = .Cells(i, 1) & "_" & .Cells(i, 2).Value
        
        If Not dicDnyKK.Exists(StKey) Then
            .Cells(i, 1) = "追加"
        Else
            
            'DictionaryのItemを変更    Item(4)に　チェック済みフラグを設定
            StItm(0) = dicDnyKK(StKey)(0)
            StItm(1) = dicDnyKK(StKey)(1)
            StItm(2) = dicDnyKK(StKey)(2)
            StItm(3) = dicDnyKK(StKey)(3)
            StItm(4) = "X"
            dicDnyKK(StKey) = StItm
        End If
    Next i

End Sub


Sub Testestest(dicdic As Dictionary)
    dicdic.Add "パソコン", "2000"
    dicdic.Add "辞書", "500"
    dicdic.Add "時計", "350"
    dicdic.Add "財布", "400"
End Sub

'************************************
'Dictionary
'アイテムからキーを取り出す
'2018/9/12
'************************************
Sub Tesdicdict()
    Dim dicdic As Dictionary
    Set dicdic = New Dictionary
    Call Testestest(dicdic)
    Dim dKeys()
    Dim dItems()
    dKeys = dicdic.Keys
    dItems = dicdic.Items
    
    Dim i           As Long
    Dim j           As Long
    Dim Cost        As Long
    Dim TradeNm     As String
  
    For i = 0 To dicdic.Count - 1
        Debug.Print "1:" & dicdic.Keys(i) & ","; dicdic.Items(i)
        Debug.Print "2:" & dicdic.Keys(i) & ","; dicdic.Item("パソコン")
        Debug.Print "3:" & dicdic("パソコン")
        Debug.Print "4:" & dicdic("2000")
        
        For j = 0 To dicdic.Count - 1
            Cost = dicdic.Item(dKeys(j))        '2000=item(dkeys(パソコン))
            Cost = dicdic.Items(j)              '2000=item(j)     j=0 :パソコン、 j=1 :時計
            
            If dicdic.Keys(j) = "時計" Then     'keys(0)="時計" ?
                Cost = dicdic.Items(j)          '350=item(0)
            End If
            
            Cost = 500
            If dicdic.Items(j) = Cost Then      'item(j)=500 ?
                TradeNm = dicdic.Keys(j)        '財布=keys(j)
            End If

        Next j
    Next i
    
'    Debug.Print dicdic.Items(2)
'    Debug.Print dicdic.Keys(2)
    dicdic.RemoveAll
End Sub

'************************************
'Dictionary
'************************************
Sub dic0_4()
    Dim Meibo       As Dictionary
    Set Meibo = New Dictionary
    
    Dim i           As Long
    Dim Str1        As String
    Dim Str2        As String
    
    With Worksheets("辞書")
        .Activate
        For i = 2 To 4
            Str1 = .Cells(i, 12).Value & Cells(i, 13).Value
            Str2 = .Cells(i, 14).Value & .Cells(i, 15).Value & Cells(i, 16).Value
            
            If Not Meibo.Exists(Str1) Then
                Meibo.Add Str1, Str2
            End If
        Next i
    End With
    
    Dim myKey()
    Dim myItm()
    myKey = Meibo.Keys()
    myItm = Meibo.Items()
    
    Dim PrvInfo As Dictionary
    Set PrvInfo = New Dictionary
    
    With Worksheets("辞書")
        .Activate
        For i = 2 To 5
            Str1 = .Cells(i, 18).Value & Cells(i, 19).Value
            Str2 = i
            
            If Not PrvInfo.Exists(Str1) Then
                PrvInfo.Add Str1, Str2
            End If
            Debug.Print PrvInfo(Str1) & "," & PrvInfo(Str2)
        Next i
    End With

    Dim pKey
    Dim pItm
    pKey = PrvInfo.Keys
    pItm = PrvInfo.Items
    Dim Row As Long
    
    Dim str3    As String
    With Worksheets("辞書")
        .Activate
        
        For i = 0 To PrvInfo.Count - 1
            Row = 2 + i
            str3 = (.Cells(i + 2, 18) & .Cells(i + 2, 19))
            .Cells(i + 2, 20).Value = Meibo(str3)
        Next i
    End With
    
    Meibo.RemoveAll
    PrvInfo.RemoveAll
 End Sub
 
'************************************
'Dictionary
'************************************
Sub dic0_3()
    Dim myDic3       As Dictionary
    Set myDic3 = New Dictionary
    
    Dim i           As Long
    Dim Str1        As String
    Dim Str2        As String
    
    With Worksheets("Sheet2")
        .Activate
        For i = 2 To 14
            Str1 = .Cells(i, 1).Value
            Str2 = .Cells(i, 2).Value
            
            If Not myDic3.Exists(Str1) Then
                myDic3.Add Str1, Str2
            End If
        Next i
    End With
    
    Dim myKey()
    Dim myItm()
    myKey = myDic3.Keys()
    myItm = myDic3.Items()
    
    With Worksheets("Sheet2")
        .Activate
        For i = 0 To myDic3.Count - 1
            .Cells(i + 2, 7).Value = myDic3.Keys(i)
            .Cells(i + 2, 8).Value = myDic3.Items(i)
            
            .Cells(i + 2, 9).Value = myKey(i)
            .Cells(i + 2, 10).Value = myItm(i)
            
            .Cells(i + 2, 5).Value = myDic3.Item(.Cells(i + 2, 4).Value)
       Next i
    End With
    myDic3.RemoveAll
 End Sub
 
'************************************
'Object
'************************************
Sub dic0_1()
    Dim myDic1      As Object
    Dim i           As Long
    
    Set myDic1 = CreateObject("Scripting.Dictionary")
    '---myDicにKeyとItemを格納する
    For i = 2 To 14
        If Not myDic1.Exists(Cells(i, 1).Value) Then
            myDic1.Add Cells(i, 1).Value, Cells(i, 2).Value
        End If
    Next i
    
    '---Itemを取り出す
    For i = 2 To 15
        Cells(i, 5).Value = myDic1(Cells(i, 4).Value)
    Next i

    Set myDic1 = Nothing
End Sub

'************************************
'Dictionary
'************************************
Sub dic0_2()
    Dim myDic2   As Dictionary
    Set myDic2 = New Dictionary
    
    Dim i       As Long
    'myDicにKeyとItemを格納する
    For i = 2 To 14
        If Not myDic2.Exists(Cells(i, 1).Value) Then
            myDic2.Add Cells(i, 1).Value, Cells(i, 2).Value
        End If
    Next i
    
    'Itemを取り出す
    For i = 2 To 14
        Cells(i, 5).Value = myDic2(Cells(i, 4).Value)
    Next i

    myDic2.RemoveAll
End Sub


'********************************************************************************
'機能定義名 ：Add_Country(Compare_MainのSub Procedure)
'機能説明   ：届出国追加項目　シートの情報を取得し☆認証資料一覧****☆　に反映
'引数       ：なし
'戻り値     ：なし
'作成       ：PTRM(2018/9/13)
'********************************************************************************
Sub Add_Country(WS_Base As Worksheet, WS_AddCntry As Worksheet, Bs_LstRow As Long, dicAddCntry As Dictionary)
    Dim Row             As Long
    Dim A_Icd           As String
    Dim i               As Long
    Dim j               As Long
    Dim ObjItem()       As String
    
    With WS_AddCntry
        For Row = 2 To 20
            i = 4
            A_Icd = .Cells(Row, 7).Value
            j = -1
            
            Do Until i > 15
                If .Cells(Row, i) = "○" Then
                    j = j + 1
                    ReDim Preserve ObjItem(j)
                    ObjItem(j) = .Cells(1, i).Value
                End If
                i = i + 1
            Loop
            
            If Not dicAddCntry.Exists(A_Icd) Then
                dicAddCntry.Add A_Icd, ObjItem
            End If
NxtRow1:
        Next Row
    End With
    
    Dim Bs_Icd      As String
    Dim Col         As Long
    j = 0

    With WS_Base
        For Row = 12 To 40
            Bs_Icd = .Cells(Row, 3).Value
            
            If dicAddCntry.Exists(Bs_Icd) Then
                Col = MyRng.Column + 1
                
                Do Until j > UBound(dicAddCntry.Item(Bs_Icd))           'Item項目が入っている分
                    Do Until dicAddCntry(Bs_Icd)(j) = .Cells(3, Col)    '101EWVTA
                        Col = Col + 1
                    Loop
                    .Cells(Row, Col) = "○"
                    j = j + 1
                Loop
            End If
            j = 0
NxtRow2:
        Next Row
    End With
End Sub


Sub Testdicdic()
    Dim WS As Worksheet
    Set WS = Worksheets("Iコード一覧表_All")
    
    Dim DicIcd  As Dictionary
    Set DicIcd = New Dictionary
    
    Dim I_Name(5) As String
    Dim i As Long
    Dim LstRow As Long
    
    i = 2
    LstRow = 40
    
    Dim icode   As String
    With WS
        For i = 2 To LstRow
            icode = Trim(Cells(i, 1).Value)
            I_Name(0) = Trim(Cells(i, 2).Value) 'JP
            I_Name(1) = Trim(Cells(i, 3).Value) 'Eng
            I_Name(2) = Left(I_Name(1), InStr(1, I_Name(1), " ") - 1) 'Kihonbusho
            I_Name(3) = Mid(I_Name(0), Len(I_Name(2)) + 2, 300) 'Eng Meisho
        
            If Not DicIcd.Exists(icode) Then
                DicIcd.Add icode, I_Name
            End If
        
        Next i
    End With
    
    Dim iKeys()
    Dim iItems()
    iKeys() = DicIcd.Keys
    iItems() = DicIcd.Items
    
    Debug.Print iKeys(0)
    Call test2(DicIcd, iKeys, iItems)
    
End Sub


Sub test2(DicIcd As Dictionary, iKeys, iItems)
    Dim WB  As Workbook
    Dim WS  As Worksheet
    Dim cWS As Worksheet
    Set WB = Workbooks("ICode.xlsx")
    Set WS = WB.Worksheets("Iコード一覧表")
    Set cWS = WB.Worksheets("Iコード一覧表_All")
    
    Dim icode As String
    Dim dicChngKomk     As Dictionary   '辞書
    Set dicChngKomk = New Dictionary
    Dim Row As Long
    
    Debug.Print iKeys(2)
    Debug.Print DicIcd(iKeys(2))(2)
    
    With cWS
        For Row = 2 To 200
            
            '項目変更情報シートの項目コード、項目コードに対応する日・英名称をＩコード一覧表シートから取得
            icode = .Cells(Row, 1).Value    'Key
            
            If Not dicChngKomk.Exists(icode) Then
                dicChngKomk.Add icode, DicIcd(icode)
            End If
NxtRow1:
        Next Row
    End With
    
    icode = "I91020800000"
    If DicIcd.Exists(icode) = False Then
    Debug.Print DicIcd.Item(icode)(0)
    Debug.Print DicIcd.Item(icode)(3)
    
    Debug.Print dicChngKomk(icode)(2)
    End If

End Sub


Sub test3()
    Dim i   As Long
    Dim j   As Long
    j = 2
    Dim WB  As Workbook
    Dim WS  As Worksheet
    Dim cWS As Worksheet
    Set WB = Workbooks("ICode.xlsx")
    Set WS = WB.Worksheets("Iコード一覧表")
    Set cWS = WB.Worksheets("Iコード一覧表_All")
    Application.ScreenUpdating = False
    
    With WS
        For i = 2 To 2106 'Step 10
            cWS.Activate
            cWS.Range(Cells(i, 1), Cells(i, 7)).Copy
            WS.Activate
            WS.Cells(j, 1).Select
            Selection.PasteSpecial Paste:=xlPasteAll
            j = j + 1
'            .Cells(i, 2) = Mid(.Cells(i, 2), 6, 100)
'            .Cells(i, 3) = Mid(.Cells(i, 3), 6, 100)
        Next i
    End With
    Application.ScreenUpdating = True

End Sub
'★★★★★Outlook★★★★★★★★★★★★★★★★★★★★★★★★★★★
Option Explicit

Public Sub Sample()
    Dim eu As Outlook.ExchangeUser
    
    Set eu = GetExchangeUserByAddress("abcd@aiueokakkiku.co.jp")
    If Not eu Is Nothing Then
        Debug.Print eu.Name, eu.Department, eu.PrimarySmtpAddress
    End If
End Sub
  
'Private Function GetExchangeUserByAddress(ByVal SmtpAddress As String) As Outlook.ExchangeUser
'    Dim myList As Outlook.AddressList
'    Dim ae As Outlook.AddressEntry
'    Dim eu As Outlook.ExchangeUser
'    Dim ret As Outlook.ExchangeUser
'    Dim ObjSession          As Object
'
'    Set ObjSession = CreateObject("Outlook.Application").Session
'
'    Set myList = ObjSession.GetGlobalAddressList
'    For Each ae In myList.AddressEntries
'        Select Case ae.AddressEntryUserType
'            Case olExchangeUserAddressEntry, olExchangeRemoteUserAddressEntry '環境に応じて変更
'                Set eu = ae.GetExchangeUser
'                If eu.PrimarySmtpAddress = SmtpAddress Then
'                    Set ret = eu
'                    Exit For
'                End If
'        End Select
'    Next
'    Set GetExchangeUserByAddress = ret
'End Function

Sub DemoAE()
 
    Dim OlkLists_Adrs       As Outlook.AddressLists
    Dim Olk_AdrsList        As Outlook.AddressList
    Dim Entries_Adrs        As Outlook.AddressEntries
    Dim Entry_Adrs          As Outlook.AddressEntry
    Dim oExUser             As Outlook.ExchangeUser
    Dim ObjSession          As Object
    Dim MlAdrs              As String
    MlAdrs = "rika_miyamoto@aiueokakakikeko.co.jp"
    
    Set ObjSession = CreateObject("Outlook.Application").Session
    Set OlkLists_Adrs = ObjSession.Session.AddressLis6ts
    
    For Each Olk_AdrsList In OlkLists_Adrs
    
        If Olk_AdrsList.AddressListType = olExchangeGlobalAddressList Then
        
            Set Entries_Adrs = Olk_AdrsList.AddressEntries
        
            For Each Entry_Adrs In Entries_Adrs
            
                If Entry_Adrs.AddressEntryUserType = olExchangeUserAddressEntry Then
                
                    Set oExUser = Entry_Adrs.GetExchangeUser
                    If oExUser.PrimarySmtpAddress = MlAdrs Then
                        Debug.Print (oExUser.JobTitle)
                        Debug.Print (oExUser.OfficeLocation)
                        Debug.Print (oExUser.BusinessTelephoneNumber)
                        Debug.Print (oExUser.Address)
                        Debug.Print (oExUser.Department)
                        Debug.Print (oExUser.FirstName)
                        Debug.Print (oExUser.LastName)
                        Debug.Print (oExUser.Name)
                        Debug.Print (oExUser.PrimarySmtpAddress)
                    End If
                End If
            Next
        End If
    Next
End Sub

Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim objRecp         As Recipient
    Dim objExchUser     As ExchangeUser
'
    If Item.MessageClass Like "IPM.TaskRequest*" Then
        Set Item = Item.GetAssociatedTask(False)
    End If
'
    For Each objRecp In Item.Recipients
        Set objExchUser = objRecp.AddressEntry.GetExchangeUser()
        If Not objExchUser Is Nothing Then
            Debug.Print objExchUser.Department
        End If
    Next

End Sub


Option Explicit

Public Sub Sample()
    Dim eu As Outlook.ExchangeUser
    
    Set eu = GetExchangeUserByAddress("abcd@aiueokakkiku.co.jp")
    If Not eu Is Nothing Then
        Debug.Print eu.Name, eu.Department, eu.PrimarySmtpAddress
    End If
End Sub
  
'Private Function GetExchangeUserByAddress(ByVal SmtpAddress As String) As Outlook.ExchangeUser
'    Dim myList As Outlook.AddressList
'    Dim ae As Outlook.AddressEntry
'    Dim eu As Outlook.ExchangeUser
'    Dim ret As Outlook.ExchangeUser
'    Dim ObjSession          As Object
'
'    Set ObjSession = CreateObject("Outlook.Application").Session
'
'    Set myList = ObjSession.GetGlobalAddressList
'    For Each ae In myList.AddressEntries
'        Select Case ae.AddressEntryUserType
'            Case olExchangeUserAddressEntry, olExchangeRemoteUserAddressEntry '環境に応じて変更
'                Set eu = ae.GetExchangeUser
'                If eu.PrimarySmtpAddress = SmtpAddress Then
'                    Set ret = eu
'                    Exit For
'                End If
'        End Select
'    Next
'    Set GetExchangeUserByAddress = ret
'End Function

Sub DemoAE()
 
    Dim OlkLists_Adrs       As Outlook.AddressLists
    Dim Olk_AdrsList        As Outlook.AddressList
    Dim Entries_Adrs        As Outlook.AddressEntries
    Dim Entry_Adrs          As Outlook.AddressEntry
    Dim oExUser             As Outlook.ExchangeUser
    Dim ObjSession          As Object
    Dim MlAdrs              As String
    MlAdrs = "rika_miyamoto@aiueokakakikeko.co.jp"
    
    Set ObjSession = CreateObject("Outlook.Application").Session
    Set OlkLists_Adrs = ObjSession.Session.AddressLis6ts
    
    For Each Olk_AdrsList In OlkLists_Adrs
    
        If Olk_AdrsList.AddressListType = olExchangeGlobalAddressList Then
        
            Set Entries_Adrs = Olk_AdrsList.AddressEntries
        
            For Each Entry_Adrs In Entries_Adrs
            
                If Entry_Adrs.AddressEntryUserType = olExchangeUserAddressEntry Then
                
                    Set oExUser = Entry_Adrs.GetExchangeUser
                    If oExUser.PrimarySmtpAddress = MlAdrs Then
                        Debug.Print (oExUser.JobTitle)
                        Debug.Print (oExUser.OfficeLocation)
                        Debug.Print (oExUser.BusinessTelephoneNumber)
                        Debug.Print (oExUser.Address)
                        Debug.Print (oExUser.Department)
                        Debug.Print (oExUser.FirstName)
                        Debug.Print (oExUser.LastName)
                        Debug.Print (oExUser.Name)
                        Debug.Print (oExUser.PrimarySmtpAddress)
                    End If
                End If
            Next
        End If
    Next
End Sub

Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim objRecp         As Recipient
    Dim objExchUser     As ExchangeUser
'
    If Item.MessageClass Like "IPM.TaskRequest*" Then
        Set Item = Item.GetAssociatedTask(False)
    End If
'
    For Each objRecp In Item.Recipients
        Set objExchUser = objRecp.AddressEntry.GetExchangeUser()
        If Not objExchUser Is Nothing Then
            Debug.Print objExchUser.Department
        End If
    Next

End Sub
'****************************************************************
'機能定義名 ：Get_MailData
'機能説明   ：Outlook　①フォルダのメールを処理(依頼メールのみ)
'引数       ：
'戻り値     ：
'作成       ：PTRM(2019/11/20)
'****************************************************************
Function Get_MailData(glbWS_Prgrs As Worksheet, glbWS_Choice As Worksheet, DicRule As Dictionary, DicFldRule As Dictionary, DicGroup As Dictionary, DicPjtWord As Dictionary, DicDivNm As Dictionary, DicBPrj As Dictionary, _
                      glbObjOlk As Object, glbObjNameSpc As Object, glbInFld As Object, _
                      glbInMainFld As Object, glbInCntFld As Object, glbInMsrFld As Object, glbInResFld As Object, _
                      SrvFld As String, WrtRow As Long, pCol As pLstCol, MlCnt) As Boolean
    Get_MailData = True
    
'    On Error Resume Next
    Dim Msg             As Outlook.MailItem
    Dim MlItem          As Object
    Dim MailCnt         As Long
    Dim AtchCnt         As Long
        
    Dim FlMsgName       As String       'メールファイル名
    Dim MailInfo(4)     As Variant
    Dim StMailBody      As String
    
    Dim DocType         As String
    Dim KeyWord         As String
    Dim Prjct           As String
    Dim ReceiveDay      As Date
    
    Dim stDay           As String
    Dim stTime          As String
    Dim DivName         As String
    Dim SenderName      As String
    Dim SenderMail      As String
    Dim Sbjct           As String
    Dim WrtStRow        As Long         '最初の記入行をメモリ
    Dim Rslt            As String
    Dim Assistant       As String

    MailCnt = glbInMainFld.Items.Count
    
    If MailCnt = 0 Then
        Get_MailData = False
        MlCnt = 0
        Exit Function
    End If
    
    Dim DicExcept       As Dictionary
    Set DicExcept = New Dictionary
    Call Make_DicExcept(glbWS_B, DicExcept) 'B資料シート除外　ワード
    
    Dim DicFlType       As Dictionary
    Set DicFlType = New Dictionary
    Call Make_DicFlType(glbWS_B, DicFlType) 'B資料シートファイル種類
    
    Dim TCnt            As Long
    Dim OutScope        As Long
    Dim AllMailCnt      As Long
    TCnt = 1
    OutScope = 0
    AllMailCnt = MailCnt
    MsgBox MailCnt & "件のメールを処理します"
    
    Do Until MailCnt = 0
        Application.ScreenUpdating = True
        Application.StatusBar = TCnt & "件目"
        Application.ScreenUpdating = False

        Set MlItem = glbInMainFld.Items(MailCnt)     '1メールを取得
        If MlItem Is Nothing Then
            GoTo Nxt_
        End If
        SenderMail = MlItem.SenderName
        
        'ファイル名に使用できない文字を変換w
        Call Replace_MailInfo(MlItem, MailInfo, StMailBody, ReceiveDay)
        Sbjct = MailInfo(2)
        If Sbjct Like "*法規認証部回答*" Then
            OutScope = OutScope + 1
            GoTo Nxt_
        End If
        
        Call GetSenderSMTPAddress(MlItem, SenderName)
        
        Dim Refer As String
        Refer = ""
        If InStr(1, Sbjct, "リマインダ") Or InStr(1, Sbjct, "リマインド") Then
            Refer = "Reminder"
            GoTo Assistant_
        End If
        
        If InStr(1, Sbjct, "参考情報") >= 1 Or InStr(1, Sbjct, "情報解禁") >= 1 Or InStr(1, Sbjct, "解禁") >= 1 Or InStr(1, StMailBody, "エンバーゴ") >= 1 Then
            Refer = "Reference"
        End If
        
        If InStr(1, StMailBody, "参考情報") >= 1 Or InStr(1, StMailBody, "情報解禁") >= 1 Or InStr(1, StMailBody, "解禁") >= 1 Then
            Refer = "Reference"
        End If
        
Assistant_:
        '送信者が　アシスタントだったら　フラグを設定
        Assistant = glbWS_Choice.Range("Assistant")
        If InStr(1, SenderName, Assistant) >= 1 Then
            Refer = "Reference"
        End If
        
        '文書の種類を取得
        DocType = ""
        If Get_DocType(DicRule, MailInfo(2), DocType, KeyWord) = False Then
            If Get_DocType(DicRule, StMailBody, DocType, KeyWord) = False Then
                DocType = ""
                MlItem.Move glbInMsrFld
                GoTo Nxt_
            End If
        End If
                    
        '件名にPW類、が含まれていたらフラグを設定(全半角 大文字 小文字)
        If Refer = "Reminder" Then
            GoTo Prjct
        End If
        
        If CkPassWordMailSbjct(MailInfo) = False Then   '件名でPWメールだったら
'            Refer = "PW"
            If Refer = "Reference" Then
            Else
                Refer = "PW"
            End If
            
        Else    '件名だけではPWではない
            Dim x       As Long
            If CkPassWordMailBody(StMailBody, x) = False Then '本文でPWと判断したら
                If Refer = "Reference" Then
                    
                Else
                    If x = 3 And (DocType = "B資料" Or DocType = "(TS/TR/TL)" Or DocType = "資料(RA/RB/RC/RD)") Then     'パスワード
                        Refer = ""
                    Else
                        Refer = "PW"
                    End If
                End If
                
            Else    '件名も本文もPWがない
                '何もしない
            End If
        End If
                    
Prjct:
       'プロジェクト名称(車種・機能)を取得
        Prjct = ""
        If Get_Prjct(MailInfo(2), DocType, Prjct) = False Then          '件名で探す
            If SrchPrjct(DicPjtWord, MailInfo, Prjct) = False Then
        
                If Get_Prjct(StMailBody, DocType, Prjct) = False Then   '本文で探す
                    Prjct = ""
                Else
                    Call FindJpRegExp(Prjct, Rslt)
                    If Rslt <> Prjct Then
                       Prjct = ""
                    End If

                End If
            End If
        End If
        
        DivName = ""
        Call Get_DivName(DicDivNm, StMailBody, DocType, DivName)
        
        'メールをファイルサーバーにコピー
        FlMsgName = ""
        stDay = Left(MailInfo(1), InStr(1, MailInfo(1), " ") - 1)       '受信日　文字列
        stTime = ""
        If DocType = "B資料" Then
            stTime = "_" & Right(MailInfo(1), Len(MailInfo(1)) - InStrRev(MailInfo(1), " "))
        Else
            stTime = ""
        End If
        
        Dim ResFld  As String
        Dim NewFld  As String
        Call SrchResFld(DicFldRule, DocType, ResFld)
        NewFld = SrvFld & "\" & ResFld & "\依頼用"
                
        '同名のファイルが存在したらファイル名に -連番 をつける
        FlMsgName = Trim(Prjct) & "_" & stDay & stTime & "_"
        Call SaveMsg(MlItem, NewFld, FlMsgName)
        
        '回答期限　Subjectから
        Dim Period          As Date
        Dim i               As Long
        Dim Tmp
        i = 0
        If DocType = "B資料" Then

            If Prjct <> "" Then
                
                If DicBPrj.Exists(Prjct) = True Then
                    Period = ReceiveDay + (7 * DicBPrj.Item(Prjct))
                Else
                    Tmp = Split(Prjct, ",")
                    Do Until i > UBound(Tmp)
                        If DicBPrj.Exists(Tmp(i)) = True Then
                            Period = ReceiveDay + (7 * DicBPrj.Item(Tmp(i)))
                            GoTo A
                        Else
                            i = i + 1
                        End If
                        
                    Loop
                    Period = ReceiveDay + 7
                End If
            Else
                Period = ReceiveDay + 7
            End If
            
        Else
            If Get_PeriodDay(MailInfo, StMailBody, Period, ReceiveDay) = False Then
                Period = 0
                GoTo A
            End If

            If Period <= Now() - 5 Then
                Period = 0
            End If

        End If
        
        Dim VolumeCnt       As Long
        Dim Sender          As String
A:
        If DocType = "B資料" Then
            If (Refer = "Reference") Then   'Refer = "PW" Or Refer = "Reminder" Or
                VolumeCnt = 0
            ElseIf Get_VolumCnt(DicExcept, DicFlType, StMailBody, AtchCnt, VolumeCnt) = False Then
                VolumeCnt = 99
            End If
            AtchCnt = 0
        
        ElseIf DocType = "(TS/TR/TL)" Then
            If InStr(1, MailInfo(2), ",-1") > 1 Then
                AtchCnt = 2
            End If
            
            If InStr(1, MailInfo(2), ",-2") > 1 Then
                AtchCnt = 3
            End If

            If InStr(1, MailInfo(2), ",-3") > 1 Then
                AtchCnt = 4
            End If

        Else
            AtchCnt = MlItem.Attachments.Count          '添付ファイルの数を取得
            Sender = ""
            If SenderName = "" Then
                Sender = MailInfo(0)
            Else
                Sender = SenderName
            End If
        End If
        
        Dim PathFlNm        As String
        If FlMsgName <> "" Then
            PathFlNm = NewFld & "\" & FlMsgName & ".msg"
        Else
            PathFlNm = ""
        End If
        
        Call Wrt_MailInfo(glbWS_Prgrs, WrtRow, MailInfo, DivName, SenderName, ReceiveDay, DocType, Prjct, Period, AtchCnt, VolumeCnt, Refer, PathFlNm, pCol)
        WrtRow = WrtRow + 1
        MlItem.Move glbInCntFld
               
        '初期化
'        Set MlItem = Nothing
        Period = 0
        VolumeCnt = 0
        AtchCnt = 0
        TCnt = TCnt + 1
'        GoTo Nxt_
Nxt_:
        Set MlItem = Nothing
        If err.Number <> 0 Then
'            Debug.Print Err.Description
        End If
        err.Clear
        MailCnt = MailCnt - 1
    Loop
    
    Application.ScreenUpdating = True
    
    MsgBox AllMailCnt & "件中　" & TCnt - 1 & "　件のメールを処理しました。" & vbCr & vbCr & _
            OutScope & "件は、対象外のメールでした"
    Application.StatusBar = ""
    Application.ScreenUpdating = False
    Exit Function
    
Err_:
    Get_MailData = False
    Call Err_Msg(99, "")
End Function

'****************************************************************
'機能定義名 ：Replace_MailInfo
'機能説明   ：ファイル名に使用できない文字を _ に置き換える
'引数       ：なし
'戻り値     ：なし
'作成       ：PTRM(2019/11/20)
'****************************************************************
Sub Replace_MailInfo(ObjItem As Object, MailInfo As Variant, StMailBody As String, ReceiveDay As Date)
    MailInfo(0) = ObjItem.SenderName
    MailInfo(1) = ObjItem.ReceivedTime
    MailInfo(2) = ObjItem.Subject
    MailInfo(3) = ObjItem.SenderEmailAddress
    MailInfo(4) = ObjItem.Subject
    StMailBody = ObjItem.Body
    ReceiveDay = MailInfo(1)
    
     Dim strBase(2)     As String
     ' ファイル名に使用できない文字を _ に置き換える
     Call ReplaceString(MailInfo(0), strBase(0), "_")   'Sender Name
     Call ReplaceString(MailInfo(1), strBase(1), "")    'Received Time
     Call ReplaceString(MailInfo(2), strBase(2), "_")   'Subject
     MailInfo(0) = strBase(0)
     MailInfo(1) = strBase(1)
     MailInfo(2) = strBase(2)
     
     strBase(0) = ""
     strBase(1) = ""
     strBase(2) = ""
End Sub

'****************************************************************
'機能定義名 ：CkPassWordMail
'機能説明   ：メール件名に　パスワード　類があるかチェック
'引数       ：なし
'戻り値     ：なし
'作成       ：PTRM(2019/11/14)
'****************************************************************
Function CkPassWordMailSbjct(MailInfo As Variant) As Boolean
    CkPassWordMailSbjct = True   'PWでない
    Dim x           As Long
    Dim Posi        As Long
    
    For x = 1 To 3
        Select Case x
            Case 1
                Posi = InStr(1, MailInfo(2), "PW", vbTextCompare)
            Case 2
                Posi = InStr(1, MailInfo(2), "PASSWORD", vbTextCompare)
            Case 3
                Posi = InStr(1, MailInfo(2), "パスワード", vbTextCompare)
        End Select
       
        If Posi >= 1 Then
            CkPassWordMailSbjct = False  'PW
            Exit Function
        End If
    Next x
End Function

'****************************************************************
'機能定義名 ：CkPassWordMail
'機能説明   ：メール本文に　パスワード　類があるかチェック
'引数       ：なし
'戻り値     ：なし
'作成       ：PTRM(2019/11/14)
'****************************************************************
Function CkPassWordMailBody(StMailBody As String, x As Long) As Boolean
    CkPassWordMailBody = True
    Dim Posi        As Long
    Dim Posi1       As Long
    Dim Posi2       As Long
    Dim Posi3       As Long
    Dim y           As Long
    x = 0
    Posi = 9999999
    For y = 1 To 3
        Select Case y
            Case 1
                Posi1 = InStr(1, StMailBody, "PW", vbTextCompare)
                If Posi1 >= 1 Then
                    Posi = Posi1
                End If
                
            Case 2
                Posi2 = InStr(1, StMailBody, "PASSWORD", vbTextCompare)
                If Posi2 >= 1 Then
                    If Posi > Posi2 Then
                        Posi = Posi2
                    End If
                End If
                
            Case 3
                Posi3 = InStr(1, StMailBody, "パスワード", vbTextCompare)
                If Posi3 >= 1 Then
                    If Posi > Posi3 Then
                        Posi = Posi3
                        x = 3
                    End If
                End If
        End Select
        
    Next
      
    If Posi = 9999999 Then
    Else
        If Posi >= 1 Then
            If (InStr(Posi, StMailBody, "別") >= 1 And InStr(Posi, StMailBody, "別") < Posi + 10) _
                Or (InStr(Posi, StMailBody, "次") >= 1 And InStr(Posi, StMailBody, "次") < Posi + 10) _
                Or (InStr(Posi, StMailBody, "他") >= 1 And InStr(Posi, StMailBody, "他") < Posi + 10) _
                Or (InStr(Posi, StMailBody, "後") >= 1 And InStr(Posi, StMailBody, "後") < Posi + 10) Then  'PWメールでない
'                Exit For
                
            Else
                CkPassWordMailBody = False  'PWメール
                Exit Function
            End If
        End If
    End If
'    Next x
End Function

'****************************************************************
'機能定義名 ：GetSenderSMTPAddress
'機能説明   ：メール差出人から　差出人/代理人を取得
'Caption    ：
'引数       ：
'戻り値     ：
'作成       ：PTRM(2019/10/14)
'****************************************************************
Function GetSenderSMTPAddress(ByVal iMail As Object, SenderName As String) As String
    Const PR_SENT_REPRESENTING_EMAIL_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x0065001e"

    If iMail Is Nothing Then
        GetSenderSMTPAddress = ""
        Exit Function
    End If

    If iMail.SenderEmailType <> "EX" Then
        Let GetSenderSMTPAddress = iMail.SenderEmailAddress
    End If
    
    If iMail.SenderEmailAddress = "owner-clear-communication-check@mega.tec.toyota.co.jp" _
        Or iMail.SenderEmailAddress = "bd-ts@mega.tec.toyota.co.jp" _
        Or iMail.SenderEmailAddress = "fv-clear-communication-check@mail.toyota.co.jp" Then
        Let GetSenderSMTPAddress = iMail.SenderEmailAddress
    End If
    
    Dim mailSender      As Object 'As Outlook.AddressEntry
    Set mailSender = iMail.Sender

    If mailSender Is Nothing Then
        Exit Function 'return vbNullString
    Else
        SenderName = mailSender.Name
        Exit Function
    End If

'    Const olExchangeUserAddressEntry = 0, olExchangeRemoteUserAddressEntry = 5
'
'    Select Case mailSender.AddressEntryUserType
'        Case olExchangeUserAddressEntry, olExchangeRemoteUserAddressEntry
'
'            Dim exchUser As Object 'As Outlook.ExchangeUser
'            Set exchUser = mailSender.GetExchangeUser()
'
'            If exchUser Is Nothing Then
'                Exit Function 'return vbNullString
'            End If
'
'            Let GetSenderSMTPAddress = exchUser.PrimarySmtpAddress
'
'        Case Else
'            Let GetSenderSMTPAddress = CStr(mailSender.PropertyAccessor.GetProperty(PR_SENT_REPRESENTING_EMAIL_ADDRESS))
'            SenderName = CStr(mailSender.PropertyAccessor.GetProperty(PR_SENT_REPRESENTING_EMAIL_ADDRESS))
'    End Select

End Function

'****************************************************************
'機能定義名 ：Get_DocType
'機能説明   ：メール件名から　文書の種類／集計項目を取得
'Caption    ：
'引数       ：
'戻り値     ：
'作成       ：PTRM(2019/10/14)
'****************************************************************
Function Get_DocType(DicRule As Dictionary, StData As Variant, DocType As String, KeyWord As String) As Boolean
    Get_DocType = False
    Dim i               As Long
    Dim cnt             As Long
    Dim PlsWord(6)      As String
    i = 0
    cnt = 0
    PlsWord(0) = "TS"       'TS審議依頼
    PlsWord(1) = "TR"
    PlsWord(2) = "TL"
    
    PlsWord(3) = "RA"       '資料
    PlsWord(4) = "RB"
    PlsWord(5) = "RC"
    PlsWord(6) = "RD"
    
    Do Until cnt > DicRule.Count - 1
            
        If InStr(1, DicRule.Keys(cnt), "_") > 2 Then    'TS審議依頼 Or 資料   (B_Material)
            Dim Tmp
            Tmp = Split(DicRule.Keys(cnt), "_")
            
            If InStr(1, StData, Tmp(0)) >= 1 Then
                KeyWord = DicRule.Keys(cnt)
                
                Select Case Tmp(1)
                    Case "審議"
                        For i = 0 To 2
                            If InStr(1, StData, PlsWord(i)) >= 1 Then
                                DocType = DicRule.Items(cnt)
                                Get_DocType = True
                                Exit Do
                            End If
                        Next i
                    
                    Case "参考" ', "資料"
                        For i = 3 To 6
                            If InStr(1, StData, PlsWord(i)) >= 1 Then
                                DocType = DicRule.Items(cnt)
                                KeyWord = DicRule.Keys(cnt)
                                Get_DocType = True
                                Exit Do
                            End If
                        Next i
                End Select
            End If
            
        ElseIf InStr(1, StData, DicRule.Keys(cnt)) >= 1 Then
            DocType = DicRule.Items(cnt)
            KeyWord = DicRule.Keys(cnt)
            Get_DocType = True
            Exit Do
        End If
        
        cnt = cnt + 1
    Loop
End Function

'********************************************************************************
'機能定義名 ：Get_Prjct
'機能説明   ：メールの件名からプロジェクト名称を抽出
'           ：、資料の場合は、特定の文字から始まるコードを取得
'引数       ：
'戻り値     ：
'作成       ：(2019/10/18)
'********************************************************************************
Function Get_Prjct(StData As Variant, DocType As String, Prjct As String) As Boolean
    Get_Prjct = False
    Dim Subject     As String
    Subject = StData
    
    '前段階でDocTypeが正しく取得できていないケースがある(、資料)
    If StrConv(DocType, vbNarrow) = "(TS/TR/TL)" Or DocType = "資料(RA/RB/RC/RD)" Then
        If SearchText(Subject, Prjct, "TS", 7) = True Then
            If DocType <> "(TS/TR/TL)" Then
                DocType = "(TS/TR/TL)"
            End If
            Get_Prjct = True
            Exit Function
        End If
        
        If SearchText(Subject, Prjct, "TR", 7) = True Then
            If DocType <> "(TS/TR/TL)" Then
                DocType = "(TS/TR/TL)"
            End If
            Get_Prjct = True
            Exit Function
        End If
        
        If SearchText(Subject, Prjct, "TL", 7) = True Then
            If DocType <> "(TS/TR/TL)" Then
                DocType = "(TS/TR/TL)"
            End If
            Get_Prjct = True
            Exit Function
        End If
        
        If SearchText(Subject, Prjct, "RA", 7) = True Then
            If DocType <> "資料(RA/RB/RC/RD)" Then
                DocType = "資料(RA/RB/RC/RD)"
            End If
            Get_Prjct = True
            Exit Function
        End If
        
        If SearchText(Subject, Prjct, "RB", 7) = True Then
            If DocType <> "資料(RA/RB/RC/RD)" Then
                DocType = "資料(RA/RB/RC/RD)"
            End If
            Get_Prjct = True
            Exit Function
        End If
        
        If SearchText(Subject, Prjct, "RC", 7) = True Then
            If DocType <> "資料(RA/RB/RC/RD)" Then
                DocType = "資料(RA/RB/RC/RD)"
            End If
            Get_Prjct = True
            Exit Function
        End If
        
        If SearchText(Subject, Prjct, "RD", 7) = True Then
            If DocType <> "資料(RA/RB/RC/RD)" Then
                DocType = "資料(RA/RB/RC/RD)"
            End If
            Get_Prjct = True
            Exit Function
        End If
    End If
    
    If DocType = "ラベル審議" Then
        If SearchText(Subject, Prjct, "No.", 9) = True Then
            Get_Prjct = True
            Exit Function
        End If
    End If

    Dim Pattern         As String
    If DocType = "伺書" Then
        Pattern = "[0-9][0-9][0-9][0-9]-[0-9][0-9][0-9][0-9]"
        If RegExpPrjct(Subject, Pattern, Prjct) = True Then
            Get_Prjct = True
            Exit Function       '●●●B
        End If
    End If

    Pattern = "[0-9][0-9][0-9][A-Z]"
    If RegExpPrjct(Subject, Pattern, Prjct) = True Then
        Get_Prjct = True
        Exit Function           '●●●B
    End If
    
    Pattern = "[A-Z][0-9][0-9][A-Z]"
    If RegExpPrjct(Subject, Pattern, Prjct) = True Then
        Get_Prjct = True
        Exit Function           'D●●A
    Else
        If Prjct Like "D???" Then
        Else
            Prjct = ""
        End If
    End If
    
End Function

'********************************************************************************
'機能定義名 ：SrchPrjct
'機能説明   ：Keywordシートと　一致する文言があるかチェック
'引数       ：
'戻り値     ：
'作成       ：(2019/10/28)
'********************************************************************************
Function SrchPrjct(DicPjtWord As Dictionary, MailInfo As Variant, Prjct As String) As Boolean
    SrchPrjct = False
    Dim Key         As String
    Dim i           As Long
    
    'Keywordシートと　一致する文言があるかチェック
    Do Until i > DicPjtWord.Count - 1
        Key = DicPjtWord.Keys(i)
        
        If InStr(1, MailInfo(2), Key) >= 1 Then
            Prjct = Key
            SrchPrjct = True
            Exit Do
        End If
        i = i + 1
    Loop
End Function


'********************************************************************************
'機能定義名 ：Get_PeriodDay
'機能説明   ：回答期限を　件名または本文から取得
'引数       ：
'戻り値     ：
'作成       ：(2019/10/18)
'********************************************************************************
Function Get_PeriodDay(MailInfo As Variant, StMailBody As String, Period As Date, ReceiveDay As Date) As Boolean
    On Error GoTo Err_
    Dim CkStr(2)        As String
    Dim Pattern(1)      As String
    Dim TrgtCnt         As Long
    Dim RegCnt          As Long
    
    CkStr(0) = MailInfo(2)      'Subject　ファイル名に使用できない文字を変換済み
    CkStr(1) = StMailBody
    CkStr(2) = MailInfo(4)      'Subject　件名そのまま
    Pattern(0) = "([\d０-９]+[/／_＿][\d０-９]+[/／_＿][\d０-９]+|" & "[\d０-９]+[年][\d０-９]+[月][\d０-９]+日)" 'yyyy/mm/dd,yyyy年㎜月dd日
    Pattern(1) = "([\d０-９]+[/／_＿][\d０-９]+|" & "[\d０-９]+[月][\d０-９]+日)"                              'mm/dd,㎜月dd日
    
    For TrgtCnt = 0 To 2         '0：件名に回答期限がなければ、　1：本文から取得
        '回答期限の日付
        RegCnt = 0
        
        Do Until RegCnt >= 2    '0：yyyy/mm/dd,yyyy年㎜月dd日、　1：mm/dd,㎜月dd日
            If RegExpDateExtract(CkStr(TrgtCnt), Pattern(RegCnt), Period, RegCnt) = True Then
                Get_PeriodDay = True
                Exit Function
            End If
            RegCnt = RegCnt + 1
        Loop
    Next TrgtCnt
    
    Dim intWeek As Integer
    
    If InStr(1, CkStr(1), "公開後") >= 1 Then
        intWeek = Mid(CkStr(1), InStr(1, CkStr(1), "公開後") + 3, 1)
        Period = ReceiveDay + (intWeek * 7)
        Get_PeriodDay = True
    End If
    Exit Function
    
Err_:
    Get_PeriodDay = False
End Function

'********************************************************************************
'機能定義名 ：SearchTxt
'機能説明   ：
'引数       ：
'戻り値     ：
'作成       ：(2019/10/18)
'********************************************************************************
Function SearchText(TrgtText As String, PartText As String, SrchTxt As String, TxtLen As Long) As Boolean
    SearchText = False
    Dim Posi        As Long
    Posi = InStr(1, TrgtText, SrchTxt)
    
    If Posi > 0 Then
        PartText = Mid(TrgtText, Posi, TxtLen)
        SearchText = True
    End If
End Function

'****************************************************************
'機能定義名 ：MoveMailMsg
'機能説明   ：Topフォルダから転記済フォルダへ移動させる
'引数       ：
'戻り値     ：
'作成       ：PTRM(2019/10/31)
'****************************************************************
Function MoveMailMsg(InMoveFld As Object, MlItem As Object) As Boolean '(glbInFld As Object, glbInMainFld As Object, InMoveFld As Object, MLItem)
    On Error GoTo Err_
    MoveMailMsg = True
    MlItem.Move InMoveFld
    Exit Function
Err_:
    MoveMailMsg = False
End Function