Sub ProcessFiles()
Dim folderPath As String
Dim fileName As String
Dim wb As Workbook
Dim ws As Worksheet
Dim outputWb As Workbook
Dim outputWs As Worksheet
Dim rowCount As Integer
Dim regexPattern As String
Dim matchFileName As Boolean
Dim matchSheetName As Boolean
Dim matchZoomValue As Boolean
Dim sheetName As String
Dim datePattern As String
Dim expensePattern As String
Dim name As String
Dim dateStr As String
' 1. 実行マクロと同じディレクトリを取得
folderPath = ThisWorkbook.Path & "\"
' マクロ実行を行うシートの情報を取得
name = Sheets("Sheet1").Range("A3").Value
dateStr = Sheets("Sheet1").Range("A4").Value
' 新規エクセルファイルを作成
Set outputWb = Workbooks.Add
Set outputWs = outputWb.Sheets(1)
outputWs.Name = "チェック結果"
outputWs.Range("A1").Value = "ファイル名"
outputWs.Range("B1").Value = "シート名"
outputWs.Range("C1").Value = "ファイルの拡大率"
outputWs.Range("D1").Value = "条件1"
outputWs.Range("E1").Value = "条件2"
outputWs.Range("F1").Value = "条件3"
' 2. ディレクトリ内の.xlsxファイルを処理
fileName = Dir(folderPath & "*.xlsx")
rowCount = 2 ' 開始行
Do While fileName <> ""
Set wb = Workbooks.Open(folderPath & fileName)
Set ws = wb.Sheets(1)
' シートを作成
outputWb.Sheets.Add After:=outputWb.Sheets(outputWb.Sheets.Count)
Set outputWs = outputWb.Sheets(outputWb.Sheets.Count)
outputWs.Name = Left(fileName, Len(fileName) - 5) ' 拡張子を除いたファイル名をシート名に
' ファイル名を出力
outputWs.Cells(2, 1).Value = fileName
' シート名を出力
outputWs.Cells(2, 2).Value = ws.Name
' ファイルの拡大率を出力
outputWs.Cells(2, 3).Value = ws.Parent.Windows(1).Zoom * 100 & "%" ' 拡大率をパーセンテージで取得
' 3. ファイル名の正規表現判定
regexPattern = ".*" & name & "\.xlsx"
matchFileName = RegExTest(fileName, regexPattern)
If matchFileName Then
outputWs.Cells(2, 4).Value = "OK"
Else
' 4. YYYYMMDD（氏名）.xlsx の判定
datePattern = ".*" & dateStr & ".*" & name & "\.xlsx"
matchFileName = RegExTest(fileName, datePattern)
If matchFileName Then
outputWs.Cells(2, 4).Value = "OK"
Else
' 5. 交通費（氏名）.xlsx の判定
expensePattern = ".*交通費.*" & name & "\.xlsx"
matchFileName = RegExTest(fileName, expensePattern)
If matchFileName Then
outputWs.Cells(2, 4).Value = "OK"
Else
outputWs.Cells(2, 4).Value = "NG"
outputWs.Cells(2, 4).Interior.Color = RGB(255, 0, 0) ' 赤色に設定
End If
End If
End If
' 6. シート名の正規表現判定
regexPattern = ".*" & name & ".*"
matchSheetName = RegExTest(ws.Name, regexPattern)
If matchSheetName Then
outputWs.Cells(2, 5).Value = "OK"
Else
outputWs.Cells(2, 5).Value = "NG"
outputWs.Cells(2, 5).Interior.Color = RGB(255, 0, 0) ' 赤色に設定
End If
' 5. ファイルの拡大率の判定
matchZoomValue = (ws.Parent.Windows(1).Zoom * 100 = 50)
If matchZoomValue Then
outputWs.Cells(2, 6).Value = "OK"
Else
outputWs.Cells(2, 6).Value = "NG"
outputWs.Cells(2, 6).Interior.Color = RGB(255, 0, 0) ' 赤色に設定
End If
wb.Close SaveChanges:=False
fileName = Dir
Loop
' 2. 新規エクセルファイルを保存
outputWb.SaveAs folderPath & "チェック結果.xlsx"
outputWb.Close SaveChanges:=False
End Sub
Function RegExTest(ByVal text As String, ByVal pattern As String) As Boolean
Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")
regex.pattern = pattern
regex.Global = False ' 最初にマッチした結果だけを取得
regex.IgnoreCase = True ' 大文字小文字を無視してマッチング
RegExTest = regex.Test(text)
End Function
