[已解决】A,B,C三列都相同的放在一个WORD中

LMY123

A,B,C三列都相同的放在一个WORD中.rar (81.42 KB, 下载次数: 25)

2013-4-1 09:53 上传

点击文件名下载附件

代码如下，请问代码错在什么地方？
Sub 合同生成()
On Error Resume Next
    Range("A2:A42").Select
    Range("A1:E42").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        SortMethod:=xlPinYin, DataOption1:=xlSortNormal
    Dim A
    Dim arr, i As Integer, n As Integer, m As Integer, strarr As String
    Dim trow As Long
    Dim WordAppX As New Word.Application
    Dim WordDocX As Word.Document
    Dim WordTableX As Word.Table
    Dim WordRowX As Word.Row
    Dim vsrange As Word.Range
    Dim myPath As String
    trow = Sheets("数据库").Range("A65536").End(xlUp).Row   '行数
    myPath = ThisWorkbook.Path
    Set WordAppX = New Word.Application
    WordAppX.Visible = False
    arr = Sheets("数据库").Range("a2:e" & trow)     '数组

For m = 1 To trow - 1
    Set WordDocX = WordAppX.Documents.Add(myPath & "\模版.doc")
    If strarr <> arr(m, 1) & arr(m, 2) & arr(m, 3) Then
        strarr = arr(m, 1) & arr(m, 2) & arr(m, 3)
For n = m To trow - 1


     If strarr = arr(n, 1) & arr(n, 2) & arr(m, 3) Then
     Set WordTableX = WordDocX.Tables(1)
     i = i + 1
      WordTableX.Rows.Add

        WordTableX.Cell(i + 1, 1).Range.Text = arr(n, 1)
        WordTableX.Cell(i + 1, 2).Range.Text = arr(n, 2)
        WordTableX.Cell(i + 1, 3).Range.Text = arr(n, 3)
        WordTableX.Cell(i + 1, 4).Range.Text = arr(n, 4)
        WordTableX.Cell(i + 1, 5).Range.Text = arr(n, 5)

    Else
        Exit For
   End If
Next n
    WordDocX.SaveAs myPath & "\" & strarr & ".doc"
    Set vsrange = Nothing
    Set WordTableX = Nothing
    WordDocX.Close
    i = 0
End If
Next m

    WordAppX.Quit
    Set WordDocX = Nothing
    Set WordAppX = Nothing
End Sub

amesman

此处:If strarr = arr(n, 1) & arr(n, 2) & arr(m, 3) Then
改成：If strarr = arr(n, 1) & arr(n, 2) & arr(n, 3) Then

LMY123

amesman 发表于 2013-4-1 11:28
此处:If strarr = arr(n, 1) & arr(n, 2) & arr(m, 3) Then
改成：If strarr = arr(n, 1) & arr(n, 2) & a ...

多谢大师指导，效果非常好，请问如果我加一列序号，并以序号来命名DOC文件，代码应该怎么改？



A,B,C三列都相同的放在一个WORD中04-01.zip (49.46 KB, 下载次数: 9)

2013-4-1 11:37 上传

点击文件名下载附件

amesman

1. Sub 合同生成()
   
2. On Error Resume Next
   
3.     Range("A2:A42").Select
   
4.     Range("A1:E42").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:= _
   
5.         xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
   
6.         SortMethod:=xlPinYin, DataOption1:=xlSortNormal
   
7.     Dim A
   
8.     Dim arr, i As Integer, n As Integer, m As Integer, strarr As String
   
9.     Dim trow As Long
   
10.     Dim WordAppX As New Word.Application
    
11.     Dim WordDocX As Word.Document
    
12.     Dim WordTableX As Word.Table
    
13.     Dim WordRowX As Word.Row
    
14.     Dim vsrange As Word.Range
    
15.     Dim myPath As String, Fn$
    
16.     trow = Sheets("数据库").Range("A65536").End(xlUp).Row   '行数
    
17.     myPath = ThisWorkbook.Path
    
18.     Set WordAppX = New Word.Application
    
19.     WordAppX.Visible = False
    
20.     arr = Sheets("数据库").Range("a2:f" & trow)     '数组
    
21. 
    
22.     For m = 1 To trow - 1
    
23.         Set WordDocX = WordAppX.Documents.Add(myPath & "\模版.doc")
    
24.         If strarr <> arr(m, 1) & arr(m, 2) & arr(m, 3) Then
    
25.             strarr = arr(m, 1) & arr(m, 2) & arr(m, 3)
    
26.             Fn = ""
    
27.             For n = m To trow - 1
    
28.                  If strarr = arr(n, 1) & arr(n, 2) & arr(n, 3) Then
    
29.                     Set WordTableX = WordDocX.Tables(1)
    
30.                     i = i + 1
    
31.                     WordTableX.Rows.Add
    
32.                   
    
33.                     WordTableX.Cell(i + 1, 1).Range.Text = arr(n, 1)
    
34.                     WordTableX.Cell(i + 1, 2).Range.Text = arr(n, 2)
    
35.                     WordTableX.Cell(i + 1, 3).Range.Text = arr(n, 3)
    
36.                     WordTableX.Cell(i + 1, 4).Range.Text = arr(n, 4)
    
37.                     WordTableX.Cell(i + 1, 5).Range.Text = arr(n, 5)
    
38.                     If Fn <> "" Then
    
39.                        Fn = Fn & "-" & arr(n, 6)
    
40.                     Else
    
41.                        Fn = arr(n, 6)
    
42.                     End If
    
43.                 Else
    
44.                     Exit For
    
45.                 End If
    
46.             Next n
    
47.             If InStr(Fn, "-") > 0 Then
    
48.                If InStr(Fn, "-") <> InStrRev(Fn, "-") Then
    
49.                   Fn = Left(Fn, InStr(Fn, "-")) & Right(Fn, Len(Fn) - InStrRev(Fn, "-"))
    
50.                End If
    
51.             End If
    
52.             WordDocX.SaveAs myPath & "" & Fn & ".doc"
    
53.             Set vsrange = Nothing
    
54.             Set WordTableX = Nothing
    
55.             WordDocX.Close
    
56.             i = 0
    
57.         End If
    
58.     Next m
    
59.    
    
60.     WordAppX.Quit
    
61.     Set WordDocX = Nothing
    
62.     Set WordAppX = Nothing
    
63. End Sub

复制代码

amesman

见附件。。。

LMY123

amesman 发表于 2013-4-1 14:13
见附件。。。

谢谢大师指导，效果非常好

LMY123

amesman 发表于 2013-4-1 14:13
见附件。。。

由于记录每天在增加，4月1日生成了1-8的WORD文档，4月2日有三个记录，即9-11，现在怎么实现只生成9-11的WORD?
增加了一个日期列
A,B,C三列都相同的放在一个WORD中04-02.zip (84.63 KB, 下载次数: 16)

2013-4-1 14:41 上传

点击文件名下载附件

amesman

LMY123 发表于 2013-4-1 14:41
由于记录每天在增加，4月1日生成了1-8的WORD文档，4月2日有三个记录，即9-11，现在怎么实现只生成9-11的 ...

没明白你的意思，只生成日期列日期为当前日期的word文档？还是判断哪些信息已经生成过，只生成未曾生成的信息到文档？如果是这种，你加个标志列就成了，生成过的标志为1，没生成的为0

LMY123

只生成未曾生成的信息到文档