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

灵犀之声

如图，目标文件夹有很多表格，每个表格的封面是相同的，内容不一样。请教各位大佬。如何批量把封面模板复制到目标文件夹里面的美格表格的Sheet1

小花感谢。

灵犀之声

实际的表格不止10个，每个里面的内容不一样，但是都需要一个相同的封面

ytmoola

1. Sub CopyTemplateToFiles()
   
2.     Dim templateFilePath As String
   
3.     Dim targetFolderPath As String
   
4.     Dim file As String
   
5.     Dim wbTemplate As Workbook
   
6.     Dim wbTarget As Workbook
   
7.     Dim sheetName As String
   
8.    
   
9.     ' 设置模板文件的路径和目标文件夹的路径
   
10.     templateFilePath = "C:\Path\To\template.xlsx"  ' 修改为你的模板文件路径
    
11.     targetFolderPath = "C:\Path\To\TargetFolder"  ' 修改为你的目标文件夹路径
    
12.    
    
13.     ' 打开模板文件
    
14.     Set wbTemplate = Workbooks.Open(templateFilePath)
    
15.     sheetName = "Sheet1" ' 假设模板文件中的Sheet1是你要复制的表格
    
16.    
    
17.     ' 遍历目标文件夹中的所有文件
    
18.     file = Dir(targetFolderPath & "*.xlsx")  ' 仅处理xlsx文件
    
19.     Do While file <> ""
    
20.         ' 打开目标文件
    
21.         Set wbTarget = Workbooks.Open(targetFolderPath & file)
    
22.         
    
23.         ' 删除目标文件中的Sheet1（如果存在）
    
24.         On Error Resume Next
    
25.         Application.DisplayAlerts = False
    
26.         wbTarget.Sheets(sheetName).Delete
    
27.         Application.DisplayAlerts = True
    
28.         On Error GoTo 0
    
29.         
    
30.         ' 复制模板文件中的Sheet1到目标文件中
    
31.         wbTemplate.Sheets(sheetName).Copy Before:=wbTarget.Sheets(1)
    
32.         
    
33.         ' 保存并关闭目标文件
    
34.         wbTarget.Close SaveChanges:=True
    
35.         
    
36.         ' 获取下一个文件
    
37.         file = Dir
    
38.     Loop
    
39.    
    
40.     ' 关闭模板文件
    
41.     wbTemplate.Close SaveChanges:=False
    
42.    
    
43.     MsgBox "模板复制完成！"
    
44. End Sub
    

复制代码

灵犀之声

发的帖子怎么没有阅读量呢？

灵犀之声

ytmoola 发表于 2024-7-11 11:29

老师，您这是AI的代码吧，用不了

ytmoola

灵犀之声 发表于 2024-7-11 12:00
老师，您这是AI的代码吧，用不了

对，应该可以参考修改一下

cidanji

那时雨

练手！有用送个花~

那时雨

那时雨 发表于 2024-7-11 12:27
练手！有用送个花~

记得 引用 Microsoft Scripting Runtime：
在 VBA 编辑器中，点击菜单栏的 工具 -> 引用...。
在弹出的对话框中，找到并勾选 Microsoft Scripting Runtime。

Qs18

Sub qs()
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    Dim wb As Workbook, xb As Workbook, sht As Worksheet, rng As Range
    Set wb = ThisWorkbook: Set sht = wb.Sheets("封面模板")
    Set rng = sht.Cells
    targetPath = ThisWorkbook.Path & "\目标文件夹\"
    fileName = Dir(targetPath & "*.xlsx")
    Do While fileName <> ""
        Set xb = Workbooks.Open(targetPath & fileName)
        rng.Copy xb.Sheets("Sheet1").Range("a1")
        xb.Close (True)
        fileName = Dir() ' 获取下一个文件名
    Loop
    MsgBox "封面模板复制完成！"
    Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub