notesscript

Sub ProcessExcelFiles()
Dim ws As New NotesUIWorkspace
Dim dialog As NotesUIDialog
Dim filePath As String
Dim fileName As String
Dim parentFolder As String
Dim parentFolderName As String
Dim excelApp As Variant
Dim workBook As Variant
Dim sheet As Variant
Dim workFile As Variant
Dim workSheet As Variant
Dim cellValue As String
Dim regExp As Variant
Dim parentDir As String
Dim folder As Variant
Dim file As Variant
Dim targetFolder As String
Dim targetFile As String
Dim workBookNew As Variant
Dim sheetNew As Variant
Dim rowIndex As Integer
Dim filterRange As Variant
Dim cell As Variant

' --- ① ファイル選択ダイアログ ---
filePath = ws.OpenFileDialog(False, "Excelファイルを選択してください", "Excelファイル|*.xlsx")
If filePath = "" Then
    Messagebox "ファイルが選択されていません", 16, "エラー"
    Exit Sub
End If

' --- ② A1セルの確認 ---
Set excelApp = CreateObject("Excel.Application")
Set workBook = excelApp.Workbooks.Open(filePath)
Set sheet = workBook.Sheets("A")

cellValue = sheet.Cells(1, 1).Value
If cellValue <> "2025" Then
    Messagebox "A1セルが'2025'ではありません", 16, "エラー"
    workBook.Close False
    excelApp.Quit
    Exit Sub
End If

' --- ③ 親フォルダ名の確認 ---
parentFolder = Mid(filePath, 1, InstrRev(filePath, "\") - 1)
parentFolderName = Mid(parentFolder, InstrRev(parentFolder, "\") + 1)

Set regExp = CreateObject("VBScript.RegExp")
regExp.Pattern = "^\d{4}年$"
If Not regExp.Test(parentFolderName) Then
    Messagebox "親フォルダ名が'数値4桁+年'ではありません", 16, "エラー"
    workBook.Close False
    excelApp.Quit
    Exit Sub
End If

' --- ④ c:\temp\Work.xlsx 作成 ---
targetFile = "C:\temp\Work.xlsx"
Set workBookNew = excelApp.Workbooks.Add
workBookNew.SaveAs targetFile

' --- ⑤ フォルダ内の全ExcelファイルのBシートB1セルをコピー ---
Set workSheet = workBookNew.Sheets(1)
rowIndex = 1

Set folder = CreateObject("Scripting.FileSystemObject").GetFolder(parentFolder)
For Each file In folder.Files
    If LCase(Right(file.Name, 5)) = ".xlsx" Then
        Set workBook = excelApp.Workbooks.Open(file.Path)
        Set sheet = workBook.Sheets("B")
        workSheet.Cells(rowIndex, 1).Value = sheet.Cells(1, 2).Value
        workBook.Close False
        rowIndex = rowIndex + 1
    End If
Next

' --- ⑥ 同列の他のフォルダのデータも追加 ---
parentDir = Mid(parentFolder, 1, InstrRev(parentFolder, "\") - 1)
Set folder = CreateObject("Scripting.FileSystemObject").GetFolder(parentDir)

For Each targetFolder In folder.SubFolders
    If regExp.Test(targetFolder.Name) And targetFolder.Path <> parentFolder Then
        For Each file In targetFolder.Files
            If LCase(Right(file.Name, 5)) = ".xlsx" Then
                Set workBook = excelApp.Workbooks.Open(file.Path)
                Set sheet = workBook.Sheets("B")
                workSheet.Cells(rowIndex, 1).Value = sheet.Cells(1, 2).Value
                workBook.Close False
                rowIndex = rowIndex + 1
            End If
        Next
    End If
Next

' --- ⑦ A-Z列にフィルターを設定 ---
Set filterRange = workSheet.Range("A1:Z" & rowIndex - 1)
filterRange.AutoFilter

' --- ⑧ A列が「K-xxxx」である行を取得 ---
rowIndex = 1
While workSheet.Cells(rowIndex, 1).Value <> ""
    If Left(workSheet.Cells(rowIndex, 1).Value, 2) = "K-" Then
        Debug.Print "K-xxxxの行: " & rowIndex
    End If
    rowIndex = rowIndex + 1
Wend

' --- 後処理 ---
workBookNew.Save
workBookNew.Close
excelApp.Quit

Messagebox "処理が完了しました", 64, "完了"

End Sub