根据 Excel 信息在文件夹中编辑并另存为 PDF

Question

我有一个问题，我有这个宏来制作合同，它会读取我的 Excel 表格上的标题，其中我有合同信息（例如薪水、姓名、分支机构）并将其替换为 word 模板。

还创建一个以员工工作办公室名称为名称的文件夹，并将合同保存为PDF，以员工姓名为文件名；因为我需要把它们送到他们的老板那里。

但我有一个问题，它确实创建了所有文件夹.. 但它总是忽略第一个分支机构（我按字母顺序排列），然后与所有其他分支机构一起正常工作。 我最终创建了一个新表，创建了一个假的分支机构来保存我需要的那个。

你们能帮我找出问题吗？

Sub CREAR_CARPETAS_X_UNIDAD()
Dim c, lRow As Long
Dim sCarpeta, sContratoModelo, sEmpresa, sNombreApellido, sUnidad As String
Dim sCarpetaUnidad As String
Dim sWord As Object

Dim wb1 As Workbook
Dim WordApp As Word.Application
Dim WordDoc As Object
    
Application.ScreenUpdating = False

t = Timer

lRow = Cells(Rows.Count, 1).End(xlUp).Row
sCarpeta = Application.ActiveWorkbook.Path
sContratoModelo = sCarpeta & "\CTS_NOVIEMBRE.docx"

'Create Folders for each unit
c = 2
Do
    On Error Resume Next
    sUnidad = UCase(Range("D" & c).Value)
    MkDir sCarpeta & "/" & sUnidad
    c = c + 1
Loop While Not c > lRow

'Copy Contract with the client name
Set WordApp = CreateObject("Word.Application")
c = 2
Do
    sUnidad = UCase(Range("D" & c).Value)
    sNombreApellido = UCase(Range("I" & c).Value)
    sCarpetaUnidad = sCarpeta & "/" & sUnidad
    
    WordApp.Visible = True
    Set WordDoc = WordApp.Documents.Open(sContratoModelo)
    
    col = 1
    Do
        With WordDoc.Content.Find
          .Text = "OBJ_" & Cells(1, col).Value
          .Replacement.Text = Cells(c, col).Value
          .Wrap = wdFindContinue
          .Execute Replace:=wdReplaceAll
        End With
        col = col + 1
    Loop While Not col > 31
            
    WordDoc.ExportAsFixedFormat OutputFileName:=sCarpetaUnidad & "\" & sNombreApellido & ".pdf", ExportFormat:=wdExportFormatPDF
    WordDoc.Close SaveChanges:=wdDoNotSaveChanges
    c = c + 1
Loop While Not c > lRow

Application.ScreenUpdating = True
MsgBox ((Timer - t) & " segundos")
End Sub

Answer 1

您确定第一个分支机构的文件夹名称有效吗？

您的代码可以大大简化：

Sub CREAR_CARPETAS_X_UNIDAD()
Application.ScreenUpdating = False
Dim c As Long, t As Single
Dim sCarpeta As String, sContratoModelo As String, sEmpresa As String
Dim sCarpetaUnidad As String, sNombreApellido As String, sUnidad As String
Dim WordApp As Word.Application, WordDoc As Word.Document

t = Timer
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True

sCarpeta = ActiveWorkbook.Path
sContratoModelo = sCarpeta & "\CTS_NOVIEMBRE.docx"

'Create Folders for each unit
For c = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    On Error Resume Next
    sUnidad = UCase(Range("D" & c).Value)
    MkDir sCarpeta & "/" & sUnidad

    'Copy Contract with the client name
    sNombreApellido = UCase(Range("I" & c).Value)
    sCarpetaUnidad = sCarpeta & "/" & sUnidad
    Set WordDoc = WordApp.Documents.Add(sContratoModelo)
    With WordDoc
        With .Content.Find
            .Wrap = wdFindContinue
            For col = 1 To 31
                .Text = "OBJ_" & Cells(1, col).Value
                .Replacement.Text = Cells(c, col).Value
                .Execute Replace:=wdReplaceAll
            Next
        End With
        .SaveAs Filename:=sCarpetaUnidad & "\" & sNombreApellido & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
        .Close SaveChanges:=wdDoNotSaveChanges
    End With
Next
Application.ScreenUpdating = True
MsgBox ((Timer - t) & " segundos")
End Sub

您也可以使用自动邮件合并。请参阅 从 Excel 运行 Mailmerge，将输出发送到单个文件，位于 Mailmerge 提示和技巧页面：

https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html