复制跑完脚本的 YTD 对应

Option Explicit

Sub CopyYTDInputData()
    '========= USER CONFIGURATION SECTION =========
    'Source and destination folder paths (do not include trailing backslash)
    Const SourceFolder As String = "C:\YourSourceFolder"
    Const DestFolder As String = "C:\YourDestinationFolder"
    
    'One-to-one corresponding filename arrays (ensure file extensions are included, e.g., .xlsx)
    Dim srcFiles As Variant
    srcFiles = Array("SourceFile1.xlsx", "SourceFile2.xlsx", "SourceFile3.xlsx")
    
    Dim dstFiles As Variant
    dstFiles = Array("DestFile1.xlsx", "DestFile2.xlsx", "DestFile3.xlsx")
    
    'Sheet name to process
    Const SheetName As String = "YTD Input"
    
    'Source range to copy (column and row)
    Const SrcCol1 As String = "C"
    Const SrcRow1 As Long = 5
    Const SrcCol2 As String = "C"
    Const SrcRow2 As Long = 6
    
    'Destination range to paste (column and row)
    Const DstCol1 As String = "D"
    Const DstRow1 As Long = 5
    Const DstCol2 As String = "D"
    Const DstRow2 As Long = 6
    '==============================================
    
    'Performance optimization
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    
    Dim i As Long
    Dim srcPath As String, dstPath As String
    Dim srcWb As Workbook, dstWb As Workbook
    Dim srcWs As Worksheet, dstWs As Worksheet
    
    'Ensure folder paths end with a backslash
    Dim srcFolder As String, dstFolder As String
    srcFolder = SourceFolder
    dstFolder = DestFolder
    If Right(srcFolder, 1) <> "\" Then srcFolder = srcFolder & "\"
    If Right(dstFolder, 1) <> "\" Then dstFolder = dstFolder & "\"
    
    'Check if the two arrays have the same length
    If UBound(srcFiles) <> UBound(dstFiles) Then
        MsgBox "Source and destination file arrays are not the same length!", vbExclamation
        GoTo CleanUp
    End If
    
    'Loop through each pair of files
    For i = LBound(srcFiles) To UBound(srcFiles)
        srcPath = srcFolder & srcFiles(i)
        dstPath = dstFolder & dstFiles(i)
        
        'Check if source file exists
        If Dir(srcPath) = "" Then
            Debug.Print "Source file not found: " & srcPath
            GoTo NextFile
        End If
        
        'Check if destination file exists
        If Dir(dstPath) = "" Then
            Debug.Print "Destination file not found: " & dstPath & ", skipped"
            GoTo NextFile
        End If
        
        'Open workbooks (destination workbook requires read/write)
        Set srcWb = Workbooks.Open(srcPath, ReadOnly:=True)
        Set dstWb = Workbooks.Open(dstPath)
        
        'Check if sheet exists in source workbook
        On Error Resume Next
        Set srcWs = srcWb.Worksheets(SheetName)
        On Error GoTo 0
        
        If srcWs Is Nothing Then
            Debug.Print "Sheet '" & SheetName & "' not found in source file: " & srcPath
            GoTo CloseWorkbooks
        End If
        
        'Check if sheet exists in destination workbook
        On Error Resume Next
        Set dstWs = dstWb.Worksheets(SheetName)
        On Error GoTo 0
        
        If dstWs Is Nothing Then
            Debug.Print "Sheet '" & SheetName & "' not found in destination file: " & dstPath & ", skipped"
            GoTo CloseWorkbooks
        End If
        
        'Copy data using the configured ranges
        'First cell: Source -> Destination
        dstWs.Range(DstCol1 & DstRow1).Value = srcWs.Range(SrcCol1 & SrcRow1).Value
        
        'Second cell: Source -> Destination
        dstWs.Range(DstCol2 & DstRow2).Value = srcWs.Range(SrcCol2 & SrcRow2).Value
        
CloseWorkbooks:
        'Close source workbook (without saving)
        If Not srcWb Is Nothing Then
            srcWb.Close SaveChanges:=False
        End If
        
        'Save and close destination workbook
        If Not dstWb Is Nothing Then
            dstWb.Close SaveChanges:=True
        End If
        
NextFile:
    Next i
    
    MsgBox "Data has been copied successfully for all files!", vbInformation
    
CleanUp:
    'Restore Excel settings
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
End Sub