用VBA将A表F列G列H列的内容从第3行开始复制到B表的B4,B5,D5单元格中，然后再以B表的B4+face命名为新的excel保存，直至最后一行

Question

用VBA将A表F列G列H列的内容从第3行开始复制到B表的B4,B5,D5单元格中，然后再以B表的B4+face命名为新的excel保存，直至最后一行

我现在的写的是这个，可是怎么都运行不了，不是不能连续命名，就是跳出来的内容不对，有大能能帮忙看看吗？我自己整了几个礼拜了😂

Sub GenerateCoverReports()
Dim wbA As Workbook '时间登记表
Set wbA = Workbooks.Open("D:\xx\xx\A.xlsx") 'A

Dim wbB As Workbook 'B
Set wbB = Workbooks.Open("D:\xx\xx\B.xlsx") 'B

Dim wsA As Worksheet
Set wsA = wbA.Sheets("汇总") ' 修改为A表实际名称
Dim lastRow As Long, i As Long

Dim wsB As Worksheet
Set wsB = wbB.Sheets("sheet1") '修改为B表实际名称

Dim newWB As Workbook
Dim savePath As String
Dim fileName As String

' 设置文件路径和表名（根据实际情况修改）
savePath = "D:\xx\xx\自动生成"   '保存路径结尾需包含反斜杠

Application.ScreenUpdating = False

     '获取F列最后一行
lastRow = wsA.Cells(wsA.Rows.Count, "F").End(xlUp).Row

    
For i = 3 To lastRow ' 处理F3-最后一行
    

  ' 复制B表到新工作簿
    wsB.Copy
    Set newWB = ActiveWorkbook
    
    With newWB.Sheets(1)
        ' 更新单元格值
        .Range("B4").Value = wsA.Range("F" & i).Value
        .Range("B5").Value = wsA.Range("G" & i).Value
        .Range("D5").Value = wsA.Range("H" & i).Value
        
        ' 生成文件名
        fileName = .Range("F" & i).Value & " cover.xlsx"
        
        ' 删除可能存在的非法文件名字符
        fileName = Replace(fileName, ":", "")
        fileName = Replace(fileName, "\", "")
        fileName = Replace(fileName, "/", "")
        fileName = Replace(fileName, "?", "")
        fileName = Replace(fileName, "*", "")
        fileName = Replace(fileName, "[", "")
        fileName = Replace(fileName, "]", "")
    End With
    
    ' 保存并关闭新工作簿
    On Error Resume Next ' 跳过已存在文件的错误
    MkDir savePath ' 如果目录不存在则创建
    On Error GoTo 0
    newWB.SaveAs savePath & fileName
    newWB.Close False
Next i

Application.ScreenUpdating = True
MsgBox "处理完成"

End Sub

Answer 1

晚上好🌙🌙🌙
本答案参考通义千问

你的代码逻辑基本正确，但可能存在一些小问题导致运行失败。以下是对代码的优化和修正，并通过有序列表列出解决方案。

---

问题分析与解决方案

1. 文件路径问题

   • savePath 变量需要确保路径末尾包含反斜杠。
   • 如果路径不存在，使用 MkDir 创建目录时可能会报错。

2. 文件名合法性检查

   • 文件名中可能包含非法字符，但你的替换逻辑是正确的，不过可以进一步简化。

3. 异常处理

   • 在保存文件时，如果文件名重复，可能会导致错误。建议添加更详细的异常处理。

4. 工作簿和工作表的引用

   • 确保 wsA 和 wsB 引用了正确的表名和路径。

5. 文件关闭逻辑

   • 在保存文件后，确保正确关闭工作簿。

---

优化后的代码

以下是优化后的代码：

Sub GenerateCoverReports()
    Dim wbA As Workbook ' A 表
    Dim wbB As Workbook ' B 表
    Dim wsA As Worksheet
    Dim wsB As Worksheet
    Dim newWB As Workbook
    Dim savePath As String
    Dim fileName As String
    Dim lastRow As Long
    Dim i As Long
    
    ' 打开 A 表和 B 表
    On Error GoTo ErrorHandler
    Set wbA = Workbooks.Open("D:\xx\xx\A.xlsx")
    Set wbB = Workbooks.Open("D:\xx\xx\B.xlsx")
    
    ' 设置工作表
    Set wsA = wbA.Sheets("汇总") ' 修改为 A 表的实际名称
    Set wsB = wbB.Sheets("Sheet1") ' 修改为 B 表的实际名称
    
    ' 设置保存路径
    savePath = "D:\xx\xx\自动生成\" ' 确保路径末尾有反斜杠
    If Dir(savePath, vbDirectory) = "" Then
        MkDir savePath
    End If
    
    Application.ScreenUpdating = False
    
    ' 获取 F 列的最后一行
    lastRow = wsA.Cells(wsA.Rows.Count, "F").End(xlUp).Row
    
    ' 遍历 F 列的数据
    For i = 3 To lastRow
        ' 复制 B 表到新工作簿
        wsB.Copy
        Set newWB = ActiveWorkbook
        
        ' 更新新工作簿中的单元格值
        With newWB.Sheets(1)
            .Range("B4").Value = wsA.Range("F" & i).Value
            .Range("B5").Value = wsA.Range("G" & i).Value
            .Range("D5").Value = wsA.Range("H" & i).Value
            
            ' 生成文件名
            fileName = .Range("B4").Value & " cover.xlsx"
            
            ' 替换非法字符
            fileName = Replace(fileName, ":", "")
            fileName = Replace(fileName, "\", "")
            fileName = Replace(fileName, "/", "")
            fileName = Replace(fileName, "?", "")
            fileName = Replace(fileName, "*", "")
            fileName = Replace(fileName, "[", "")
            fileName = Replace(fileName, "]", "")
            fileName = Replace(fileName, "|", "")
        End With
        
        ' 保存并关闭新工作簿
        On Error Resume Next ' 跳过已存在文件的错误
        newWB.SaveAs Filename:=savePath & fileName, FileFormat:=xlOpenXMLWorkbook
        On Error GoTo 0
        newWB.Close SaveChanges:=False
    Next i
    
    ' 清理资源
    wbA.Close SaveChanges:=False
    wbB.Close SaveChanges:=False
    
    Application.ScreenUpdating = True
    MsgBox "处理完成！"
    Exit Sub
    
ErrorHandler:
    MsgBox "发生错误: " & Err.Description
    If Not newWB Is Nothing Then newWB.Close SaveChanges:=False
    If Not wbA Is Nothing Then wbA.Close SaveChanges:=False
    If Not wbB Is Nothing Then wbB.Close SaveChanges:=False
    Application.ScreenUpdating = True
End Sub

---

代码优化点说明

1. 文件路径检查

   • 使用 Dir 检查路径是否存在，如果不存在则使用 MkDir 创建。

2. 异常处理

   • 在保存文件时使用 On Error Resume Next 跳过文件名重复的错误。
   • 在错误处理中清理所有打开的工作簿。

3. 文件名合法性

   • 替换非法字符时增加了对竖线 (|) 的处理。

4. 资源释放

   • 在 Exit Sub 后关闭所有工作簿。
   • 在错误处理中确保所有打开的工作簿被正确关闭。

---

测试步骤

1. 确保 A 表和 B 表路径正确。
2. 确保 A 表的 "汇总" 工作表和 B 表的 "Sheet1" 工作表存在。
3. 确保保存路径 D:\xx\xx\自动生成\ 存在或脚本会自动创建。
4. 运行代码，观察是否成功生成文件。

希望以上代码能够解决你的问题！