Option Explicit
Sub マクロ開始()
Call init開始時刻
Dim wsMainSheet As Worksheet
Dim fileCheck As Long
Dim currentDirPathRangeList As Range, currentDirPathRange As Range
Dim subDirCheckBoxRangeList As Range, subDirCheckBoxRange As Range
Dim fileNames() As String
Dim fileExtention As Variant
fileExtention = Split(FILE_EXTENSION, ",")
Set wsMainSheet = ActiveSheet
Set currentDirPathRangeList = タイトル名指定でリスト値のRange情報を取得(TITLE_NAME_BY_TARGET_DIR, wsMainSheet)
Set subDirCheckBoxRangeList = タイトル名指定でリスト値のRange情報を取得(TITLE_NAME_BY_DO_SUB_DIR, wsMainSheet)
Call 全体前処理(wsMainSheet)
With wsMainSheet
Dim i As Long
i = 0
If Not (currentDirPathRangeList Is Nothing) Then
For Each currentDirPathRange In currentDirPathRangeList
fileCheck = isDirectoryExist(CStr(currentDirPathRange.Value))
If 0 > fileCheck Then
MsgBox "以下のパスは存在しません。" + Chr(10) + "「" + currentDirPathRange.Value + "」"
End
End If
i = i + 1
Next
End If
End With
Call setステータスバー("対象ファイル集計中...")
With ActiveSheet
i = 1
If Not (currentDirPathRangeList Is Nothing) Then
For Each currentDirPathRange In currentDirPathRangeList
fileCheck = isDirectoryExist(CStr(currentDirPathRange.Value))
If 2 = fileCheck Then
Call 一次配列に値を追加(fileNames, CStr(currentDirPathRange.Value))
Else
Dim shapesCount As Long
Dim checkBoxChecked As Variant
Dim topLeftCellRow As Variant, topLeftCellColumn As Variant
Dim ShapesInfoList As Variant
ShapesInfoList = getShapesProperty(wsMainSheet, msoFormControl, xlCheckBox)
checkBoxChecked = False
If IsArrayEx(ShapesInfoList) > 0 Then
For shapesCount = LBound(ShapesInfoList) To UBound(ShapesInfoList)
topLeftCellRow = ShapesInfoList(shapesCount, 8)
topLeftCellColumn = ShapesInfoList(shapesCount, 9)
If Not IsEmpty(topLeftCellRow) And topLeftCellRow = currentDirPathRange.Row _
And topLeftCellColumn = subDirCheckBoxRangeList.Item(0).Column Then
If 1 = ShapesInfoList(shapesCount, 2) Then
checkBoxChecked = True
End If
Exit For
End If
Next shapesCount
End If
Call doRepeat(currentDirPathRange, fileExtention, fileNames, checkBoxChecked)
End If
i = i + 1
Next
End If
End With
Call ファイル処理(fileNames)
Call 全体後処理(wsMainSheet)
MsgBox "処理が終了しました。(処理時間:" & get処理時刻() & ")"
End Sub
Function ファイル処理(fileNames() As String)
If 1 > IsArrayEx(fileNames) Then
MsgBox "処理対象ファイルが存在しません。"
Exit Function
End If
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim fileName As Variant
Dim targetWB As Workbook
Dim targetSheet As Worksheet
Dim index As Long, total As Long
Dim defaultSaveFormat As Long
defaultSaveFormat = Application.defaultSaveFormat
Dim unDealTargetSheetFlag As Boolean
Dim results() As Variant
index = 1
total = UBound(fileNames) + 1
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For Each fileName In fileNames
Call setステータスバー("(" & index & "/" & total & ")" & FSO.GetFileName(fileName))
index = index + 1
Set targetWB = Workbooks.Open(fileName, UpdateLinks:=0, IgnoreReadOnlyRecommended:=False)
unDealTargetSheetFlag = ブックOPEN後処理(fileName, targetWB, results)
If False = unDealTargetSheetFlag Then
Dim i As Integer
For i = 1 To targetWB.Worksheets.Count
Set targetSheet = targetWB.Worksheets(i)
Call シート毎処理(fileName, targetSheet, results)
Next i
End If
Dim ファイルCLOSE方法区分値 As Long
ファイルCLOSE方法区分値 = ブックCLOSE前処理(fileName, targetWB, results)
If ファイルCLOSE方法区分値 = ファイルCLOSE方法区分.保存しないで閉じる Then
targetWB.Close
ElseIf ファイルCLOSE方法区分値 = ファイルCLOSE方法区分.保存して閉じる Then
targetWB.Save
targetWB.Close
ElseIf ファイルCLOSE方法区分値 = ファイルCLOSE方法区分.保存しないで閉じない Then
ElseIf ファイルCLOSE方法区分値 = ファイルCLOSE方法区分.保存して閉じない Then
targetWB.Save
ElseIf ファイルCLOSE方法区分値 = ファイルCLOSE方法区分.処理中断 Then
End
End If
Next
Call 実行結果内容編集処理(results)
If Not Not results Then
If UBound(results, 2) <> 0 Then
Application.defaultSaveFormat = xlOpenXMLWorkbook
Set targetWB = Workbooks.Add
Call 雛形シートコピー(targetWB)
Dim MaxRow As Integer
With targetWB.ActiveSheet.UsedRange
MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
End With
MaxRow = MaxRow + 1
targetWB.ActiveSheet.Range(Cells(MaxRow, 1), Cells(UBound(results, 2) + 2, UBound(results) + 1)) = 二次元配列行列逆転(results)
Dim MaxCol As Integer
With targetWB.ActiveSheet
MaxRow = .UsedRange.Find("*", , xlFormulas, xlByRows, xlPrevious).Row
MaxCol = .UsedRange.Find("*", , xlFormulas, xlByColumns, xlPrevious).Column
.Range(.Cells(2, 1), .Cells(2, MaxCol)).Copy
.Range(.Cells(2 + 1, 1), .Cells(MaxRow, MaxCol)).PasteSpecial (xlPasteFormats)
End With
Call 実行結果書式編集処理(targetWB.ActiveSheet)
targetWB.ActiveSheet.Cells(1, 1).Select
Call 不要シート削除(targetWB, RESULT_SHEET_NAME)
Else
MsgBox "処理結果は0件です。"
End If
Else
MsgBox "処理結果は0件です。"
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.StatusBar = False
Application.defaultSaveFormat = defaultSaveFormat
If Not Not results Then
If UBound(results, 2) <> 0 Then
targetWB.Activate
End If
End If
End Function
Sub 雛形シートコピー(targetWB As Workbook)
Dim myWorkBook As String
Dim newWorkBook As String
Dim targetSheet As Worksheet
Dim sheetName As String
myWorkBook = ThisWorkbook.Name
newWorkBook = targetWB.Name
Workbooks(myWorkBook).Activate
Dim i As Integer
For i = 1 To Workbooks(myWorkBook).Worksheets.Count
Set targetSheet = Workbooks(myWorkBook).Worksheets(i)
If TEMPLATE_SHEET_NAME = targetSheet.Name Then
Workbooks(myWorkBook).Sheets(TEMPLATE_SHEET_NAME).Copy _
Before:=Workbooks(newWorkBook).Sheets(1)
End If
Next i
Workbooks(targetWB.Name).Sheets(TEMPLATE_SHEET_NAME).Activate
Workbooks(targetWB.Name).Sheets(TEMPLATE_SHEET_NAME).Name = RESULT_SHEET_NAME
End Sub