Public Function OpenTargetFile(ByVal TargetFilePath As String, _
ByVal KindSheetName As String, _
ByVal RenameString As String) As Boolean
'ファイル名に指定したキーワードを含むXLSファイルを開く
'引数1：TargetFilePath マスタファイルが格納されているファイルパスを渡す
'引数2：KindSheetName 読み込むマスタの種類を示す文字列("役職条件マスタ"など)
'引数3：RenameString 読み込んだマスタのリネーム用文字列
'戻値：成功＝TRUE、失敗＝FALSE
Dim wksBook As Workbook 'ワークブックオブジェクト
Dim wksSheet As Worksheet 'ワークシートオブジェクト
Dim strName As String 'ファイル名を格納
Dim strNonExt As String '拡張子を除外したファイル名を格納
Dim latestFileName As String '最新のファイル
Dim nameLen As Integer 'ファイル名の長さ
Dim nameDate As String 'シート名の日付文字
Dim sheetMax As Integer 'シートの最終インデックス
Dim isChecked As Boolean 'チェックフラグ
OpenTargetFile = True
'エラーハンドリング
On Error GoTo Hdl_ERROR
'最新のファイル名を取得(ファイルの存在確認も兼ねて)
latestFileName = GetLatestFileName(KindSheetName, TargetFilePath)
'該当ファイルがあったらチェックOK
If latestFileName <> "" Then
isChecked = True
Else
isChecked = False
End If
If isChecked = True Then 'ファイル名チェックOKなら実行
'マスタがバッティングするので古いシートがあったら削除
For Each wksSheet In ThisWorkbook.Worksheets
If wksSheet.Name = RenameString Then
wksSheet.Visible = xlSheetVisible
Call DeleteSheetFromPartialSheetName(KindSheetName, ThisWorkbook.Name)
Exit For
End If
Next wksSheet
sheetMax = ThisWorkbook.Worksheets.Count
Set wksBook = Workbooks.Open(TargetFilePath & "\" & latestFileName) '対象を開く
Set wksSheet = ThisWorkbook.Worksheets(sheetMax) '最終のシートを設定し
wksBook.Worksheets(1).Copy after:=wksSheet '最終インデックスにコピー
wksBook.Saved = True '上書き確認がうざいので上書き済みにし
wksBook.Close '対象を閉じる
sheetMax = ThisWorkbook.Worksheets.Count 'Maxが変わるので再読み込みして
Set wksSheet = ThisWorkbook.Worksheets(sheetMax) 'オブジェクトをコピー先シートにして
wksSheet.Name = RenameString 'シート名を変更
End If
Set wksSheet = Nothing
Set wksBook = Nothing
Exit Function
Hdl_ERROR:
'オブジェクト解放
Set wksSheet = Nothing
Set wksBook = Nothing
OpenTargetFile = False
End Function
Function SaveSheetAsNewBook(ByVal OutputSheet As Worksheet, _
Optional ByVal SavefilePath As String = "") As Boolean
'指定したシートを別ブックとして保存
'引数1 OutputSheet: 保存するシートオブジェクト
Dim newbook As Workbook '新しいブックオブジェクト
Dim objBook As Workbook 'このブック格納用オブジェクト
Dim wksSheet As Worksheet 'ワークシートオブジェクト
Dim orgSheets As Integer '呼び出し元シートの「新しいブックのシート数」を格納
Dim shtIndex As Integer '新しいブックのシートインデックスを格納
Dim strSheetName As String 'シート名を格納
Dim strShtKind As String 'シートの種別を格納
Dim strDate As String '日付を格納
Dim currentPath As String 'このブックのパス
Dim filePath As String 'ファイルパスを格納
Dim fileName As String '出力するファイル名を格納
Dim fullPath As String '最終出力ディレクトリまでのフルパスを格納
Dim isError As Boolean 'エラーフラグ
Dim fso As FileSystemObject 'ファイル操作用
Dim strSeqNum As String '連番格納用
Dim SeqNum As Integer '連番
'エラーハンドリング
On Error GoTo Hdl_SAVE_ERROR
'渡されたオブジェクトが空オブジェクトか判定
If IsEmpty(OutputSheet) <> True Then
'空ならFileSystemObjectを設定する
Set fso = New FileSystemObject
Else
GoTo Hdl_SAVE_ERROR
End If
'出力ディレクトリの定義
If SavefilePath = "" Then 'ディレクトリが指定されていなければ
currentPath = Application.ThisWorkbook.Path 'カレントにこのブックのパス名を設定
filePath = currentPath & "\" & STORE_DIR 'マスタファイルの出力ディレクトリ
strDate = Replace(Format$(Date, "YYYYMMDD"), "/", "") '本日日付の定義
fullPath = filePath & "\" & strDate '最終のフルパス
Else
currentPath = SavefilePath 'カレントディレクトリ
filePath = SavefilePath '指定ディレクトリを設定
strDate = "" '日付は空にする
fullPath = filePath
End If
'オートフィルタの判定
If OutputSheet.FilterMode = True Then
OutputSheet.ShowAllData 'オートフィルタモード解除
End If
'新しいブックの作成
orgSheets = Application.SheetsInNewWorkbook '「新しいブックのシート数」をメモしておく
strSheetName = OutputSheet.Name '現在のシート（コピー元）の名前をメモしておく
Application.SheetsInNewWorkbook = 1 '新規作成時のデフォルトシート数を1に設定
Set newbook = Workbooks.Add '新しいブックを（メモリ上に）作成
Application.SheetsInNewWorkbook = orgSheets '「新しいブックのシート数」を元に戻しておく
'新しいシートにコピーする
OutputSheet.Copy before:=newbook.Worksheets(1)
shtIndex = newbook.Worksheets.Count 'シート数を取得
Application.DisplayAlerts = False '確認警告を無効に
newbook.Worksheets(shtIndex).Delete '空シートを削除
Application.DisplayAlerts = True '確認警告を有効に
'保存の判定
If SavefilePath = "" Then '渡されたパス名が空だったら
If fso.FolderExists(filePath) = False Then '出力ディレクトリがなかったら
' カレントの直下に出力フォルダを作成する
Call fso.CreateFolder(filePath)
'当日日付ディレクトリがなかったら作成する
If fso.FolderExists(fullPath) = False Then
Call fso.CreateFolder(fullPath)
End If
'マスタ種別を取得
strShtKind = JudgeSheetKind(strSheetName)
'マスタ種別が「該当なし」でなければ
If strShtKind <> "" Then
'最新の連番を取得し
SeqNum = GetTargetFileSeq(strShtKind, fullPath)
'ファイル名を設定し
fileName = strShtKind & "_" & strDate & "_" & Format$(CStr(SeqNum + 1), "00")
'保存する
newbook.SaveAs fullPath & "\" & fileName & ".xls"
'邪魔なので閉じる
Application.Workbooks(fileName & ".xls").Close
End If
Else
'当日日付ディレクトリがなかったら作成する
If fso.FolderExists(fullPath) = False Then
Call fso.CreateFolder(fullPath)
End If
'マスタ種別を取得
strShtKind = JudgeSheetKind(strSheetName)
'マスタ種別が「該当なし」でなければ
If strShtKind <> "" Then
'最新の連番を取得し
SeqNum = GetTargetFileSeq(strShtKind, fullPath)
'存在しなければ初期値を設定し
If SeqNum = -255 Then SeqNum = 0
'ファイル名を設定し
fileName = strShtKind & "_" & strDate & "_" & Format$(CStr(SeqNum + 1), "00")
'保存する
newbook.SaveAs fullPath & "\" & fileName & ".xls"
'邪魔なので閉じる
Application.Workbooks(fileName & ".xls").Close
End If
End If
Else
SaveSheetAsNewBook = False
newbook.Close
Exit Function
End If
'開いていたブックを閉じる
'オブジェクト解放
Set fso = Nothing
Set newbook = Nothing
'成功を戻す
SaveSheetAsNewBook = True
Exit Function
Lbl_NO_MATCH:
Application.DisplayAlerts = True
SaveSheetAsNewBook = False
Hdl_SAVE_ERROR:
'オブジェクト解放
Set fso = Nothing
Set newbook = Nothing
Set objBook = Nothing
Set wksSheet = Nothing
Application.DisplayAlerts = True
'失敗を戻す
SaveSheetAsNewBook = False
End Function
Function GetTargetFileSeq(ByVal KindTargetFile As String, _
ByVal TargetFilePath As String) As Integer
'指定ディレクトリに指定種別のファイルが存在するかチェックし、
'最新ファイルの連番を返す
'
'引数1：KindTargetFile マスタ種別を表す文字列
'引数2：TargetFilePath マスタのあるディレクトリ
'戻り値：成功=0以上 存在しない=-255 エラー=-1
Dim FSO As New FileSystemObject 'FSO
Dim myFolder As Folder 'フォルダオブジェクト
Dim objFile As File 'ファイルオブジェクト
Dim strName As String 'ファイル名を格納
Dim strNonExt As String '拡張子を除外したファイル名を格納
Dim nameLen As Integer 'ファイル名の長さ
Dim strSeqNum As String 'ファイル連番(文字列)
Dim SeqNum As Integer 'ファイル連番
Dim MaxSeq As Integer '連番の最大値
Dim matchCount As Integer '存在判定のためのカウンタ
'エラーハンドリング
On Error GoTo Hdl_ERROR
'初期値設定
SeqNum = 0
MaxSeq = 0
matchCount = 0
'FSOの初期化
Set FSO = New FileSystemObject
'フォルダオブジェクトの指定
Set myFolder = FSO.GetFolder(TargetFilePath) 'フォルダオブジェクトのセット
'ファイルの読み込み
For Each objFile In myFolder.Files
'前方一致でファイル名を検査
If objFile.Name Like KindTargetFile & "*" & ".xls" Then
'ファイル名の取得を行う
strName = objFile.Name 'ファイル名を取得し
nameLen = Len(strName) 'ファイル名の長さを取得し
strNonExt = FSO.GetBaseName(objFile.Path & _
"\" & objFile.Name) '拡張子抜きのファイル名を取得
nameLen = Len(strNonExt) '長さの補正を行う
If DateCheck(Mid$(strNonExt, nameLen - 10, 8)) = True Then '日付が埋め込まれているか
If Mid$(strNonExt, nameLen - 2, 1) = "_" And _
IsNumeric(Mid(strNonExt, nameLen - 1, 2)) = True Then '"_nn"の形式か判定
'連番の判定
strSeqNum = Mid$(strNonExt, nameLen - 1, 2)
If IsNumeric(strSeqNum) = True Then '数値だったら
SeqNum = CInt(strSeqNum) '文字列から数値にして
If SeqNum > MaxSeq Then '数値の比較を行う
MaxSeq = SeqNum
End If
matchCount = matchCount + 1
End If
End If
End If
End If
Next objFile
If matchCount = 0 Then
GetTargetFileSeq = -255
Else
GetTargetFileSeq = MaxSeq
End If
Exit Function
Hdl_ERROR:
Set objFile = Nothing
Set myFolder = Nothing
Set FSO = Nothing
GetTargetFileSeq = -1
End Function
Function GetLatestFileName(ByVal KindTargetFile As String, _
ByVal TargetFilePath As String) As String
'指定ディレクトリに指定種別のファイルが存在するかチェックし、
'最新ファイルのファイル名を返す
'
'引数1：KindTargetFile マスタ種別を表す文字列
'引数2：TargetFilePath マスタのあるディレクトリ
'戻り値：成功=ファイル名,存在しない="",エラー="%"
Dim fso As New FileSystemObject 'FSO
Dim myFolder As Folder 'フォルダオブジェクト
Dim objFile As File 'ファイルオブジェクト
Dim strName As String 'ファイル名を格納
Dim strNonExt As String '拡張子を除外したファイル名を格納
Dim nameLen As Integer 'ファイル名の長さ
Dim strSeqNum As String 'ファイル連番(文字列)
Dim SeqNum As Integer 'ファイル連番
Dim MaxSeq As Integer '連番の最大値
Dim latestFileName As String '最新ファイル名
Dim matchCount As Integer '存在判定のためのカウンタ
'エラーハンドリング
On Error GoTo Hdl_ERROR
'初期値設定
SeqNum = 0
MaxSeq = 0
matchCount = 0
latestFileName = ""
'FSOの初期化
Set fso = New FileSystemObject
'フォルダオブジェクトの指定
Set myFolder = fso.GetFolder(TargetFilePath) 'フォルダオブジェクトのセット
'ファイルの読み込み
For Each objFile In myFolder.Files
'前方一致でファイル名を検査
If objFile.Name Like KindTargetFile & "*" & ".xls" Then
'ファイル名の取得を行う
strName = objFile.Name 'ファイル名を取得し
nameLen = Len(strName) 'ファイル名の長さを取得し
strNonExt = fso.GetBaseName(objFile.Path & _
"\" & objFile.Name) '拡張子抜きのファイル名を取得
nameLen = Len(strNonExt) '長さの補正を行う
If DateCheck(Mid$(strNonExt, nameLen - 10, 8)) = True Then '日付が埋め込まれているか
If Mid$(strNonExt, nameLen - 2, 1) = "_" And _
IsNumeric(Mid(strNonExt, nameLen - 1, 2)) = True Then '"_nn"の形式か判定
'連番の判定
strSeqNum = Mid$(strNonExt, nameLen - 1, 2)
latestFileName = objFile.Name
If IsNumeric(strSeqNum) = True Then '数値だったら
SeqNum = CInt(strSeqNum) '文字列から数値にして
If SeqNum > MaxSeq Then '数値の比較を行う
MaxSeq = SeqNum
latestFileName = objFile.Name
End If
matchCount = matchCount + 1
End If
End If
End If
End If
Next objFile
If matchCount = 0 Then '見つからなかったら
GetLatestFileName = ""
Else '見つかったら
GetLatestFileName = latestFileName
End If
Exit Function
Hdl_ERROR:
Set objFile = Nothing
Set myFolder = Nothing
Set fso = Nothing
GetLatestFileName = "%"
End Function
Function JudgeSheetKind(ByVal TargetSheetName As String) As String
'指定したシート名で前方から"_"を検索して、"_"の直前までの文字列を取得し、
'ファイル名のルールに沿っているかを判定する
'判定した結果、ルールに沿うならばマスタ種別を表す文字列を返す
Dim i As Integer '汎用カウンタ
Dim myLen As Integer 'シート名の長さ
Dim myPos As Variant '"_"の最初の位置
Dim strKind As String '最初の"_"までのシート名
Dim KindArray(3) As String 'マスタ種別ワードの格納用
Dim KindMax As Integer '配列最大値
Dim bolExistFlg As Boolean '合致フラグ
'フラグ初期化
bolExistFlg = False
'マスタ種別ワードの定義
KindArray(1) = PRFX_ACL
KindArray(2) = PRFX_KSJ
KindArray(3) = DIFF_RES_ACL
'"_"の検索
myPos = InStr(1, TargetSheetName, "_", vbTextCompare)
'文字検索中にエラーが起きたらそのまま抜ける
If IsNull(myPos) = True Then
JudgeSheetKind = "False"
Exit Function
End If
'検索結果を判定して
If myPos = 0 Then '検索結果が0だったら
'指定文字列をそのまま格納
strKind = TargetSheetName
Else '検索結果がヒットだったら
'"_"の直前までの文字列を格納
strKind = Mid$(TargetSheetName, 1, myPos - 1)
End If
KindMax = UBound(KindArray)
'種別の判定
For i = 1 To KindMax Step 1
If strKind = KindArray(i) Then
bolExistFlg = True
Exit For
End If
Next
'結果の通知
If bolExistFlg = True Then '該当種別があったら
JudgeSheetKind = strKind '種別文字列を返す
Else
JudgeSheetKind = "" 'なかったら空を返す
End If
End Function
'対象シートをCSV化する
'Open strExFileName For Output Access Write As #Fn
'のような感じで事前にファイルをオープンさせておく必要あり
'
Function ExportCSV(ByRef Fn As Integer, ByRef wksTarget As Worksheet) As Long
Dim RangeNum As Range
Dim Count As Long
Dim Limit As Long
Limit = wksTarget.UsedRange.Columns.Count - 1
On Error GoTo Hdl_ERROR
For Each RangeNum In wksTarget.UsedRange.Rows
For Count = 1 To Limit
Write #Fn, "" & Trim(RangeNum.Columns(Count).Text);
Next Count
Write #Fn, "" & Trim(RangeNum.Columns(Count).Text)
Next
ExportCSV = True
Exit Function
Hdl_ERROR:
ExportCSV = Count
End Function
|