AIGC标识 源文件夹中每个xlsm文件里所有MTH开头的Sheet页,复制到对应的目标文件夹中的同名xlsm文件

Sub CopyMTHSheetsToTarget()
    Dim sourceFolder As String
    Dim targetFolder As String
    Dim sourceFile As String
    Dim targetFile As String
    Dim wbSource As Workbook
    Dim wbTarget As Workbook
    Dim ws As Worksheet
    Dim wsName As String
    Dim fileCount As Integer
    Dim copiedCount As Integer
    Dim fso As Object
    Dim folder As Object
    Dim file As Object
    
    ' Set folder paths (modify according to your actual paths)
    sourceFolder = "C:\SourceFolderPath\"    ' Change to your source folder path
    targetFolder = "C:\TargetFolderPath\"   ' Change to your target folder path
    
    ' Ensure path ends with backslash
    If Right(sourceFolder, 1) <> "\" Then sourceFolder = sourceFolder & "\"
    If Right(targetFolder, 1) <> "\" Then targetFolder = targetFolder & "\"
    
    ' Create FileSystemObject
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' Check if source folder exists
    If Not fso.FolderExists(sourceFolder) Then
        MsgBox "Source folder does not exist: " & sourceFolder, vbExclamation, "Error"
        Exit Sub
    End If
    
    ' Check if target folder exists
    If Not fso.FolderExists(targetFolder) Then
        MsgBox "Target folder does not exist: " & targetFolder, vbExclamation, "Error"
        Exit Sub
    End If
    
    ' Get source folder
    Set folder = fso.GetFolder(sourceFolder)
    
    ' Turn off screen updating and alerts to improve performance
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' Loop through each file in the source folder
    For Each file In folder.Files
        ' Check if file extension is xlsm (case-insensitive)
        If LCase(fso.GetExtensionName(file.Name)) = "xlsm" Then
            sourceFile = file.Name
            targetFile = targetFolder & sourceFile
            
            ' Check if target file exists using FileSystemObject
            If fso.FileExists(targetFile) Then
                Debug.Print "Processing: " & sourceFile
                
                ' Open source file (read-only mode)
                Set wbSource = Workbooks.Open(sourceFolder & sourceFile, ReadOnly:=True)
                
                ' Open target file
                Set wbTarget = Workbooks.Open(targetFile)
                
                ' Iterate through all worksheets in source file
                For Each ws In wbSource.Worksheets
                    wsName = ws.Name
                    
                    ' Check if worksheet name starts with "MTH" (case-insensitive)
                    If UCase(Left(wsName, 3)) = "MTH" Then
                        ' Copy worksheet to target file
                        ws.Copy After:=wbTarget.Sheets(wbTarget.Sheets.Count)
                        copiedCount = copiedCount + 1
                        Debug.Print "  Copied worksheet: " & wsName
                    End If
                Next ws
                
                ' Save and close target file
                wbTarget.Save
                wbTarget.Close
                
                ' Close source file without saving
                wbSource.Close SaveChanges:=False
                
                fileCount = fileCount + 1
                Debug.Print "Finished processing: " & sourceFile
                Debug.Print "-----------------------------------"
            Else
                Debug.Print "Warning: Target file not found - " & targetFile
            End If
        End If
    Next file
    
    ' Restore screen updating and alerts
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    ' Display completion message
    MsgBox "Processing completed!" & vbCrLf & _
           "Total files processed: " & fileCount & vbCrLf & _
           "Total worksheets copied: " & copiedCount & vbCrLf & _
           "Check Immediate Window (Ctrl+G) for details.", _
           vbInformation, "Copy Complete"
End Sub

 

posted @ 2026-07-10 12:38  窝窝头一块钱8个  阅读(3)  评论(0)    收藏  举报