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 タグ名
' 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