home page自动填写日期等

Sub FillHomePage()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim folderPath As String
    Dim fileName As String
    Dim fileCode As String
    Dim fixedDate1 As String, fixedDate2 As String
    Dim fixedVal6 As Variant, fixedVal7 As Variant, fixedVal8 As Variant
    
    ' ---------- Modify the following parameters according to your needs ----------
    folderPath = "C:\YourTargetFolder\"          ' Folder containing the xlsm files (end with backslash)
    fixedDate1 = "20240101"                      ' Value for C3
    fixedDate2 = "20240331"                      ' Value for C4
    fixedVal6 = "SomeValue6"                     ' Value for C6 (change to your actual value)
    fixedVal7 = "SomeValue7"                     ' Value for C7
    fixedVal8 = "SomeValue8"                     ' Value for C8
    ' ----------------------------------------------------------------------------
    
    ' Disable screen updating for speed
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    ' Check if folder exists
    If Dir(folderPath, vbDirectory) = "" Then
        MsgBox "Folder does not exist: " & folderPath, vbExclamation
        GoTo CleanUp
    End If
    
    ' Loop through all xlsm files in the folder
    fileName = Dir(folderPath & "*.xlsm")
    Do While fileName <> ""
        ' Extract file code (LB_xxx or SB_xx) from filename
        fileCode = ExtractFileCode(fileName)
        If fileCode = "" Then
            Debug.Print "No code found in filename: " & fileName
            GoTo NextFile
        End If
        
        ' Open the workbook
        On Error Resume Next
        Set wb = Workbooks.Open(folderPath & fileName)
        If Err.Number <> 0 Then
            Debug.Print "Failed to open: " & fileName
            Err.Clear
            GoTo NextFile
        End If
        On Error GoTo 0
        
        ' Access the "Home Page" sheet
        On Error Resume Next
        Set ws = wb.Sheets("Home Page")
        If Err.Number <> 0 Then
            Debug.Print "Sheet 'Home Page' not found in: " & fileName
            wb.Close False
            Err.Clear
            GoTo NextFile
        End If
        On Error GoTo 0
        
        ' Fill the cells
        ws.Range("C3").Value = fixedDate1
        ws.Range("C4").Value = fixedDate2
        ws.Range("C5").Value = fileCode
        ws.Range("C6").Value = fixedVal6
        ws.Range("C7").Value = fixedVal7
        ws.Range("C8").Value = fixedVal8
        
        ' Save and close
        wb.Save
        wb.Close False
        
        ' Release object
        Set wb = Nothing
        Set ws = Nothing
        
NextFile:
        ' Ensure any open workbook is closed if error occurred before closing
        If Not wb Is Nothing Then
            On Error Resume Next
            wb.Close False
            On Error GoTo 0
            Set wb = Nothing
        End If
        Set ws = Nothing
        fileName = Dir()
    Loop
    
    MsgBox "Home Page update completed for all files!", vbInformation

CleanUp:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

' Extract file code (LB_xxx or SB_xx) from filename
Function ExtractFileCode(ByVal fileName As String) As String
    Dim regEx As Object, matches As Object
    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Pattern = "(LB_[A-Za-z0-9]+|SB_[A-Za-z0-9]+)"
    regEx.IgnoreCase = True
    regEx.Global = False
    If regEx.Test(fileName) Then
        Set matches = regEx.Execute(fileName)
        If matches.Count > 0 Then
            ExtractFileCode = matches(0).Value
        End If
    End If
    Set regEx = Nothing
End Function