[已解决]如何excel中批量生成对账函

程江艳

如何将excel中各企业欠款引用到word企业对账函中

最佳答案

月排行榜 / 总排行榜

JLxiangwei

2014-11-18 14:19

程江艳 发表于 2014-11-18 13:31
像这种的，麻烦了，非常感谢

你原来的excel中有代码，根据书签来修改
Private Sub CommandButton1_Click()
    Call SCXZH
End Sub

Sub SCXZH()
On Error Resume Next
    t1 = Now()
    Dim MaxL, LstL As Long
    MaxL = Application.Rows.Count
    'On Error Resume Next    '捕捉错误
    Dim wdDoc As Word.Document
    Dim FileModel As String
    Dim FileXZH As String
    FileModel = ThisWorkbook.Path & "\询证函模板.doc"   '定义word文件路径,名字自己修改,我设定为2.doc
    Dim fso As Object, sfile As Object, blnExist As Boolean
    Dim Vendname, JDcom As String
    Dim Enddate
    Dim Reportdate
    Dim AR, AP
    Dim MyRange As Range
    t = 1       '索引号
    Application.ScreenUpdating = False  '关闭屏幕刷新
   
    Set fso = CreateObject("Scripting.FileSystemObject") '创建FileSystemObject对象
    Set wdapp = CreateObject("Word.Application")
    wdapp.Visible = True '可见
    Set wdDoc = wdapp.Documents.Open(FileModel)
    'Set wdDoc = GetObject(FileModel)  '打开word询证函模板文件
    Enddate = Format(ActiveSheet.Cells(2, "j"), "yyyy年m月d日")
    Reportdate = Format(ActiveSheet.Cells(3, "j"), "yyyy-m-d")
   
    LstL = ActiveSheet.Cells(MaxL, 1).End(xlUp).Row
    With ActiveSheet
        JDcom = .Name
        
        For j = 2 To LstL
            Vendname = .Cells(j, 2)
            AR = Format(.Cells(j, 3), "#,##0.00")
            AP = Format(.Cells(j, 4), "#,##0.00")
            FileXZH = ThisWorkbook.Path & "\询证函明细\" & JDcom & "-询证函-" & .Cells(j, 2) & ".doc"
Check_FileExist:
            blnExist = fso.FileExists(FileXZH) '判断文件是否存在
            If blnExist Then
                    fso.DeleteFile (FileXZH)
            End If
            
            With wdDoc
                endloc1 = .Bookmarks("VENDOR").End
                .Range(Start:=endloc1, End:=endloc1).InsertAfter Vendname
                endloc2 = .Bookmarks("EndDate").End
                .Range(Start:=endloc2, End:=endloc2).InsertAfter Enddate
                endloc3 = .Bookmarks("AR_JD").End
                .Range(Start:=endloc3, End:=endloc3).InsertAfter AR
                endloc4 = .Bookmarks("IndexNo").End
                .Range(Start:=endloc4, End:=endloc4).InsertAfter t
                endloc5 = .Bookmarks("AP_JD").End
                .Range(Start:=endloc5, End:=endloc5).InsertAfter AP
                endloc7 = .Bookmarks("JDCOM").End
                .Range(Start:=endloc7, End:=endloc7).InsertAfter JDcom
                endloc8 = .Bookmarks("ReportDate").End
                .Range(Start:=endloc8, End:=endloc8).InsertAfter Reportdate
               .SaveAs FileXZH     '另存为word
               '清空写入数据
                .Range(Start:=endloc8, End:=endloc8).Delete unit:=wdCharacter, Count:=Len(Reportdate)
                .Range(Start:=endloc7, End:=endloc7).Delete unit:=wdCharacter, Count:=Len(JDcom)
                .Range(Start:=endloc5, End:=endloc5).Delete unit:=wdCharacter, Count:=Len(AP)
                .Range(Start:=endloc3 + 1, End:=endloc3 + 1).Delete unit:=wdCharacter, Count:=Len(AR)
                .Range(Start:=endloc2 + 1, End:=endloc2 + 1).Delete unit:=wdCharacter, Count:=Len(Enddate)
                .Range(Start:=endloc1 + 1, End:=endloc1 + 1).Delete unit:=wdCharacter, Count:=Len(Vendname)
                .Range(Start:=endloc4, End:=endloc4).Delete unit:=wdCharacter, Count:=Len(t)
            End With
            t = t + 1
        Next j
    End With
    wdDoc.Close False    '关闭word
    Set wdDoc = Nothing
    Application.ScreenUpdating = True '开启屏幕刷新
    t2 = Now()
    MsgBox "OK!" & "耗时" & DateDiff("S", t1, t2) & "秒！"
End Sub


稍微修改了一下
询证函程序.rar (222.14 KB, 下载次数: 345)

2014-11-18 14:18 上传

点击文件名下载附件


请测试

跳转到最佳答案楼层

JLxiangwei

你能做一个模拟结果吗

程江艳

JLxiangwei 发表于 2014-11-18 13:10
你能做一个模拟结果吗

像这种的，麻烦了，非常感谢

JLxiangwei

程江艳 发表于 2014-11-18 13:31
像这种的，麻烦了，非常感谢

你原来的excel中有代码，根据书签来修改
Private Sub CommandButton1_Click()
    Call SCXZH
End Sub

Sub SCXZH()
On Error Resume Next
    t1 = Now()
    Dim MaxL, LstL As Long
    MaxL = Application.Rows.Count
    'On Error Resume Next    '捕捉错误
    Dim wdDoc As Word.Document
    Dim FileModel As String
    Dim FileXZH As String
    FileModel = ThisWorkbook.Path & "\询证函模板.doc"   '定义word文件路径,名字自己修改,我设定为2.doc
    Dim fso As Object, sfile As Object, blnExist As Boolean
    Dim Vendname, JDcom As String
    Dim Enddate
    Dim Reportdate
    Dim AR, AP
    Dim MyRange As Range
    t = 1       '索引号
    Application.ScreenUpdating = False  '关闭屏幕刷新
   
    Set fso = CreateObject("Scripting.FileSystemObject") '创建FileSystemObject对象
    Set wdapp = CreateObject("Word.Application")
    wdapp.Visible = True '可见
    Set wdDoc = wdapp.Documents.Open(FileModel)
    'Set wdDoc = GetObject(FileModel)  '打开word询证函模板文件
    Enddate = Format(ActiveSheet.Cells(2, "j"), "yyyy年m月d日")
    Reportdate = Format(ActiveSheet.Cells(3, "j"), "yyyy-m-d")
   
    LstL = ActiveSheet.Cells(MaxL, 1).End(xlUp).Row
    With ActiveSheet
        JDcom = .Name
        
        For j = 2 To LstL
            Vendname = .Cells(j, 2)
            AR = Format(.Cells(j, 3), "#,##0.00")
            AP = Format(.Cells(j, 4), "#,##0.00")
            FileXZH = ThisWorkbook.Path & "\询证函明细\" & JDcom & "-询证函-" & .Cells(j, 2) & ".doc"
Check_FileExist:
            blnExist = fso.FileExists(FileXZH) '判断文件是否存在
            If blnExist Then
                    fso.DeleteFile (FileXZH)
            End If
            
            With wdDoc
                endloc1 = .Bookmarks("VENDOR").End
                .Range(Start:=endloc1, End:=endloc1).InsertAfter Vendname
                endloc2 = .Bookmarks("EndDate").End
                .Range(Start:=endloc2, End:=endloc2).InsertAfter Enddate
                endloc3 = .Bookmarks("AR_JD").End
                .Range(Start:=endloc3, End:=endloc3).InsertAfter AR
                endloc4 = .Bookmarks("IndexNo").End
                .Range(Start:=endloc4, End:=endloc4).InsertAfter t
                endloc5 = .Bookmarks("AP_JD").End
                .Range(Start:=endloc5, End:=endloc5).InsertAfter AP
                endloc7 = .Bookmarks("JDCOM").End
                .Range(Start:=endloc7, End:=endloc7).InsertAfter JDcom
                endloc8 = .Bookmarks("ReportDate").End
                .Range(Start:=endloc8, End:=endloc8).InsertAfter Reportdate
               .SaveAs FileXZH     '另存为word
               '清空写入数据
                .Range(Start:=endloc8, End:=endloc8).Delete unit:=wdCharacter, Count:=Len(Reportdate)
                .Range(Start:=endloc7, End:=endloc7).Delete unit:=wdCharacter, Count:=Len(JDcom)
                .Range(Start:=endloc5, End:=endloc5).Delete unit:=wdCharacter, Count:=Len(AP)
                .Range(Start:=endloc3 + 1, End:=endloc3 + 1).Delete unit:=wdCharacter, Count:=Len(AR)
                .Range(Start:=endloc2 + 1, End:=endloc2 + 1).Delete unit:=wdCharacter, Count:=Len(Enddate)
                .Range(Start:=endloc1 + 1, End:=endloc1 + 1).Delete unit:=wdCharacter, Count:=Len(Vendname)
                .Range(Start:=endloc4, End:=endloc4).Delete unit:=wdCharacter, Count:=Len(t)
            End With
            t = t + 1
        Next j
    End With
    wdDoc.Close False    '关闭word
    Set wdDoc = Nothing
    Application.ScreenUpdating = True '开启屏幕刷新
    t2 = Now()
    MsgBox "OK!" & "耗时" & DateDiff("S", t1, t2) & "秒！"
End Sub


稍微修改了一下
询证函程序.rar (222.14 KB, 下载次数: 345)

2014-11-18 14:18 上传

点击文件名下载附件


请测试