VBA复制启用宏的工作簿并从列表中重命名每个工作簿

Posted 2023-03-29

【中文标题】VBA复制启用宏的工作簿并从列表中重命名每个工作簿

【英文标题】：VBA to duplicate macro enabled workbook and rename each one from list

【发布时间】：2021-08-28 10:55:42

【问题描述】：

您好，我需要多次复制启用宏的工作簿，并从 1 列 A 中工作表上的名称列表重命名每个复制的工作簿。这是我一直在尝试的代码，但它一直运行到一个

运行时错误 1004 另存为工作簿对象失败。

非常感谢任何帮助。

Sub Test2()
 
    Dim wb As Workbook
    Dim rNames As Range, c As Range, r As Range
 
    'Current file's list of names and ids on sheet1.
    Set rNames = Worksheets("Sheet1").Range("A2", Worksheets("Sheet1").Range("A2").End(xlDown))
 
    'Path and name to master workbook to open for copy, saveas.
    Set wb = Workbooks.Open("C:\Desktop\Q2\Test.xlsm")
 
    For Each c In rNames
        With wb
            .Worksheets("Sheet1").Range("A1").Value = c.Offset(, 1).Value 'ID
 
            'Path and name for copied workbook
            .SaveAs Filename:="\Desktop\Q2\Test" & c.Value, FileFormat:=52, CreateBackup:=False
        End With
 
        Set wb = ActiveWorkbook
    Next c

    wb.Close

End Sub

【问题讨论】：

c 中的样本值是多少？文件名是否以.xlsm 结尾？

【参考方案1】：

我已经测试了您的代码，唯一的区别是我将文件存储在“C:\tmp\Test.xlsx”中，并且为了简单起见，将“保存到”文件名设置为“\tmp\Test”。

它运行时没有错误消息，因此请验证您的桌面路径是否正确。我肯定没有“C:\Desktop”，我希望在“C:”和您的桌面文件夹之间有一个“Users\user name”部分。

但是新文件中的 A1 将是空白的，我相信你想要这里的新文件名。要解决此问题，请跳过“c.Offset”部分并仅替换为“c”。这是因为您的 c.Offset 语句返回“空”。

PS！运行时错误 1004 可能是您尝试保存到已使用或以某种方式阻止使用的文件名。因此，如果您一遍又一遍地这样做，则需要在每次运行之间手动删除文件，或者在尝试保存新文件之前包含删除现有文件的代码。

BR 弗兰克