代码求助：批量复制封面到多个工作簿

Qs18

试试................

ykcbf1100

参与一下，fso

ykcbf1100

封面复制。。。

1. Sub ykcbf()   '//2024.7.11   封面复制
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = ThisWorkbook.Sheets("封面模板")
   
5.     p = ThisWorkbook.Path & "\目标文件夹"
   
6.     For Each f In fso.GetFolder(p).Files
   
7.         If LCase$(f.Name) Like "*.xls*" Then
   
8.             fn = fso.GetBaseName(f)
   
9.             Set wb = Workbooks.Open(f, 0)
   
10.             sh.Cells.Copy wb.Sheets("Sheet1").[a1]
    
11.             wb.Close 1
    
12.         End If
    
13.     Next f
    
14.     Application.ScreenUpdating = True
    
15.     MsgBox "OK！"
    
16. End Sub
    

复制代码

liulang0808

Sub 按钮1_Click()
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "请选择对应文件夹"
        If .Show Then fd = .SelectedItems(1) Else Exit Sub '
    End With
    Set fso = CreateObject("scripting.filesystemobject")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error Resume Next
    Set sh = ThisWorkbook.Sheets("封面模板")
    For Each f In fso.getfolder(fd).Files
        With Workbooks.Open(f)
            sh.Copy before:=.Sheets(1)
            .Sheets("Sheet1").Delete
            .Sheets(1).Name = "Sheet1"
            .Save
            .Close False
        End With
    Next f
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

liulang0808

供参考。。。。。。

灵犀之声

ykcbf1100 发表于 2024-7-11 12:44
封面复制。。。

感谢老师，小花花送上

灵犀之声

liulang0808 发表于 2024-7-11 12:49
Sub 按钮1_Click()
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileN ...

感谢老师的鼎力相助

灵犀之声

cidanji 发表于 2024-7-11 12:24

谢谢老师，今天鲜花送完了啦，明天补上