精华内容
下载资源
问答
  • 数千人考试,需要做准考证,虽然可以用文档合并,但由于种种原因,只能用VBA来做了。 原始数据在xlsx文件中,表头: 把需要做的准考证做成“准考证模板.docx”,只一页: 并与xlsx文件放在一起,当前目录下建...

    数千人考试,需要做准考证,虽然可以用文档合并,但由于种种原因,只能用VBA来做了。

    原始数据在xlsx文件中,表头:

    把需要做的准考证做成“准考证模板.docx”,只一页:

    并与xlsx文件放在一起,当前目录下建一目录 photo ,里面放的是照片,所有照片的文件名都是 身份证号.jpg,在xlsx中写VBA代码:

    Sub zkz()
        Dim wd As New Word.Application, shp As Object, ar()
        photopath$ = ThisWorkbook.Path & "\photo\"
        docpath$ = ThisWorkbook.Path & "\"
        rowscount% = Range("A65536").End(3).Row - 1
        ar = Range("a2").Resize(rowscount, 7).Value
        docfname$ = "准考证.docx"
        docpathfname$ = docpath & docfname
        FileCopy docpath & "准考证模板.docx", docpathfname
        With wd
            .Documents.Open docpathfname
            .Application.ScreenUpdating = 0
            .Application.DisplayAlerts = False
            .Visible = 0
            .ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
            .Selection.WholeStory
            .Selection.Copy 制
            If rowscount > 3 Then
                For i% = 1 To rowscount - 2 Step 2
                    .Selection.EndKey Unit:=wdStory
                    .Selection.InsertBreak Type:=wdPageBreak
                    .Selection.PasteAndFormat (wdPasteDefault)
                Next i
            End If
            i = 1
            For Each t In .ActiveDocument.Tables
                t.Range.Cells(5).Range.Text = ar(i, 6)
                t.Range.Cells(7).Range.Text = ar(i, 1)
                t.Range.Cells(9).Range.Text = ar(i, 7)
                t.Range.Cells(11).Range.Text = ar(i, 2)
                t.Range.Cells(13).Range.Text = ar(i, 5)
                t.Range.Cells(17).Range.Text = ar(i, 3)
                t.Range.Cells(19).Range.Text = Right("00" & ar(i, 4), 3) & "考室"
                phfname$ = Dir(photopath & ar(i, 7) & ".jpg")
                If phfname = "" Then
                    t.Range.Cells(3).Range.Text = "无相片"
                    ar(i, 1) = "无相片"
                Else
                    t.Range.Cells(3).Range.InlineShapes.AddPicture Filename:=photopath & phfname
                    ar(i, 1) = "有相片"
                End If
                i = i + 1
                If i > UBound(ar) Then Exit For
            Next
        End With
        wd.Documents.Save
        wd.Quit
        Set wd = Nothing
        [j1] = "备注"
        [j2].Resize(UBound(ar), 1) = ar
        MsgBox "准考证已生成,请查看" & docpathfname & ",J列为有无照片的情况请核查"
    End Sub

    由于是在xlsx中运行的代码调用word所以要引用micosoft word *****,否则报错

    展开全文
  • 之前我们看到用VB.NET调用Excel VBA的例子比较多,本次是使用VB.NET向Word VBA传递参数,并调用Word VBA生成Word报告或PDF文档。 在Word VBA中,可访问数据库,获得自己想展示的数据,灵活度比较高。 运行环境:VS...
  • “拳不离手,曲不离口”(简易批量生成效果)一、实用场景1、批量生成邀请函2、批量生成通知书3、批量生成宣传稿件4、批量生成报告5、批量生成合同......二、思路及代码1、先建立word模板,可以用dot,也可以用dotx,...

    78eb46e4ac034955df06d4eb185d3502.png

    拳不离手,曲不离口

    925e96218764a8f9886fc3776aa12856.gif

    (简易批量生成效果)

    一、实用场景

    1、批量生成邀请函

    2、批量生成通知书

    3、批量生成宣传稿件

    4、批量生成报告

    5、批量生成合同

    ......

    二、思路及代码

    1、先建立word模板,可以用dot,也可以用dotx,还可以用docx

    2、把固定文字模板写好。

    3、关键步骤:

    (1)在需要替换的位置插入标签

    a13c382a0bca2bfc0eda18db61813ad9.png

    (2)对插入书签进行命名,便于之后替换填入相应内容

    4、EXCEL对应word模板便签建立字段,以便填入数据。

    a66c8b0fb50e5675850d41b8970623bc.png

    5、VBA编程要点

    (1)创建一个WORD生成函数

    (2)主程序通过循环,获取数据,调用word生成函数

    6、word生成函数

    Function createword( ) As Boolean '创建word函数返还的值为逻辑值  Dim myword As Word.Application, mydoc As Word.Document  '定义2个变量,分别为word应用程序,及word文档。word文档必须在word应用程序中使用。    Dim str1 As String    Set myword = New Word.Application    With myword        Set mydoc = .documents.Add(template:="d:\excel批量生成word(模板).docx", Visible:=True)  '此为模板文件及所在位置的绝对引用,可以替换为inputbox输入(可以采用函数变量的传递方式),或者是相对引用。        With .Selection            .Goto what:=wdgotobookmark, Name:="标题"       '对应word文档中的标签位置,输入特定值。本案例采用的是辅助表法。固定辅助表特定位置的值进行数据输入            .typetext Text:=Worksheets("temp").Cells(2, 1)            .Goto what:=wdgotobookmark, Name:="单位名称"            .typetext Text:=Worksheets("temp").Cells(2, 2)             .Goto what:=wdgotobookmark, Name:="内容"            .typetext Text:=Worksheets("temp").Cells(2, 3)            .Goto what:=wdgotobookmark, Name:="日期"            .typetext Text:=Worksheets("temp").Cells(2, 4)        End With    mydoc.SaveAs ThisWorkbook.Path & "\" & Worksheets("temp").Cells(2, 1) & ".docx"  '对应特定内容保存文件名    mydoc.Close         '完成一次调用关闭文档,清空mydoc变量    Set mydoc = NothingEnd Withcreateword = True      ' 函数范围true。本函数可以增加一个判断是否生成下一条的选项,可以自行增加   IF msgbox("具体内容", vbInformation+vbYesNo,'提示') = vbYes then createword = true else createword =falseEnd Function

    7、主程序

    Sub 主程序()Dim i As Integer '定义一个循环变量Dim j As Integer '定义一个变量保存行号Dim shtemp As Worksheet '保存临时表的引用。临时变量表变量Dim sht1 As Worksheet   '导出数据表格变量    On Error GoTo err1    '捕捉文件生成错误    Set shtemp = Worksheets("temp") '判断临时表格是否存在label1:    Set sht1 = Worksheets("sheet1") '引用数据表,sheet1,可以为任意表格名称。    j = sht1.Range("a1").CurrentRegion.Rows.Count ' 获取数据源表活动单位格的行号数量    '复制表头    sht1.Range("a1:c1").Copy  shtemp.Range("a1") '把数据复制到临时表    For i = 2 To j '循环调用数据,生成文档       sht1.Activate       sht1.Range(Cells(i, 1), Cells(i, 4)).Copy   shtemp.Range("a2")  '把特定数据复制到选择张贴单元格       shtemp.Range("a1:c2").Columns.AutoFit       If Not createword() Then Exit For '调用函数,判断是否进入下一个循环。此处是为了配合函数中判断语句使用。    Next    Exit Suberr1:  '捕捉错误 如果没有temp文件,    Set shtemp = Worksheets.Add    shtemp.Name = "temp"    GoTo label1End Sub

    技术交流请加力哥微信:tiny_007

    4a10fc0b671c543708fc1f636a94f44a.png

    展开全文
  • 发布一个可直接在word中,根据指定连接字段生成数据字典的宏,原文及代码:Generating Data Dictionary or Database Design Document using MS Word Macros ,实用于Sql Server ...1,新建一个word文档,在文档中新...

            发布一个可直接在word中,根据指定连接字段生成数据字典的宏,原文及代码:Generating Data Dictionary or Database Design Document using MS Word Macros ,实用于Sql Server 2005。2000下不行,2008没测试过……

            用法:

            1,新建一个word文档,在文档中新建一个宏,将代码copy到里面;

            2,添加对Microsoft ActiveX Data Object的引用;

            3,修改里面的连接字段Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;password=123;Initial Catalog=Northwind;Data Source=(local)

            4,保存,并运行宏中的About方法

            原代码中有几个不太完美的地方,由于之前接触过一点VBA,花了两个小时,动手改了一下:

            1,汉化(其实就换了几个字符串而已:-D);

            2,新增“描述”列,对应表中字段的说明(这个才是最有用的,想不通为啥“洋鬼子”不把此列显示出来);

            3,将对表的描述,作为二级大纲标题显示出来;

            4,在文档中生成TOC(如果一个项目中有上百张表,可以想象没有TOC的文档,可读性是多么差)。

            代码直接贴在下面,希望有兴趣的朋友继续改进,别忘了发我一份就行:-)

     

    ContractedBlock.gifExpandedBlockStart.gifCode
    'Attribute VB_Name = "NewMacros"

    Sub Start()
    'Attribute About.VB_Description = "Macro created 3/18/2008 by shashi"
    '
    Attribute About.VB_ProcData.VB_Invoke_Func = "Normal.NewMacros.About"
    '
    '
     Macro created 3/18/2008 by shashi
    '
    Dim conn As New ADODB.Connection
    Dim rsMain As New ADODB.Recordset
    Dim rsFields As New ADODB.Recordset
    Dim rsKey As New ADODB.Recordset
    Dim rsKeyTemp As ADODB.Recordset
    Dim Range As Range
    Dim row As Integer
    Dim strQuery As String
    Dim strFieldType As String
    Dim I As Long

    'Open a connection object
    If conn.State = 1 Then conn.Close
    conn.Open 
    "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;password=123456;Initial Catalog=PQMAGIC;Data Source=(local)"

    'Open the recordset to retrieve the tables in the database
    If rsMain.State = 1 Then rsMain.Close
    rsMain.Open 
    "Select tb.[name],ex.value from sys.tables as tb inner join sys.extended_properties as ex" & _
    " on tb.[object_id]=ex.major_id where tb.[name]<>'sysdiagrams' and ex.minor_id=0 order by name", conn, adOpenKeyset, adLockOptimistic

    row 
    = 1
    'Iterate through the tables recordset
    While Not rsMain.EOF
        
    'Start with the active document
        With Word.ActiveDocument
                
    'Procedure to set the table name
                Call SetTableName(rsMain(0), rsMain(1))
                
                
    'Query to get the Indexes,Views,Stored Procedures,Functions,Triggers of the table
                
                strQuery 
    = "select ind.name,'INDEX' as col2 from sys.indexes ind inner join sys.tables tab" & _
                           
    " on ind.object_id = tab.object_id where tab.name =  '" & rsMain(0& "'" & _
                           
    " and ind.name is not null" & _
                           
    " union" & _
                           
    " Select Distinct Procedures.Name, 'View'  as col2 From SysObjects" & _
                           
    " Join (SysObjects Procedures Join SysDepends on Procedures.Id = SysDepends.Id)" & _
                           
    " On SysDepends.DepId = SysObjects.Id Where SysObjects.XType = 'U'" & _
                           
    " And Procedures.XType = 'V' And SysObjects.Name =  '" & rsMain(0& "'" & _
                           
    " union" & _
                           
    " Select Distinct Procedures.Name, 'Stored Procedure'  as col2 From SysObjects" & _
                           
    " Join (SysObjects Procedures Join SysDepends on Procedures.Id = SysDepends.Id)" & _
                           
    " On SysDepends.DepId = SysObjects.Id Where SysObjects.XType = 'U'" & _
                           
    " And Procedures.XType = 'P'And SysObjects.Name = '" & rsMain(0& "'" & _
                           
    " AND   (lower(Procedures.Name) like 'spalias%' or lower(Procedures.Name) like 'spcustom%' " & _
                           
    " or lower(Procedures.Name) like 'spncustom%') " & _
                           
    " union" & _
                           
    " Select Distinct Procedures.Name, 'Function'  as col2 From SysObjects" & _
                           
    " Join (SysObjects Procedures Join SysDepends on Procedures.Id = SysDepends.Id)" & _
                           
    " On SysDepends.DepId = SysObjects.Id Where SysObjects.XType = 'U'" & _
                           
    " And Procedures.XType in ( 'Fn','If','Tf') And SysObjects.Name =  '" & rsMain(0& "'" & _
                           
    " union" & _
                           
    " Select Distinct Procedures.Name, 'Trigger'  as col2 From SysObjects" & _
                           
    " Join (SysObjects Procedures Join SysDepends on Procedures.Id = SysDepends.Id)" & _
                           
    " On SysDepends.DepId = SysObjects.Id Where SysObjects.XType = 'U'" & _
                           
    " And Procedures.XType = 'Tr' And SysObjects.Name =  '" & rsMain(0& "'"

                
    'Create a recordset to find Indexes,Views,Stored Procedures,Functions,Triggers of the table
                If rsKey.State = 1 Then rsKey.Close
                rsKey.Open strQuery, conn, adOpenKeyset, adLockReadOnly
                

                
    '***************Index************************
                If Not rsKey Is Nothing Then
                    
    'Clone the recordset object to find the indexes of the table
                     Set rsKeyTemp = rsKey.Clone(adLockReadOnly)
                     rsKeyTemp.Filter 
    = "col2='INDEX'"
                     
    'Set the labelling in the document
                     Call SetHeading("索引:")
                     
    If rsKeyTemp.EOF Then
                         
    Call SetTextAfter("-无-")
                     
    End If
                     
    While Not rsKeyTemp.EOF
                         
    Call SetTextAfter(rsKeyTemp(0))
                         rsKeyTemp.MoveNext
                     
    Wend
                    
    '****************************************************
                    '******************Views***************
                    
                    
    'Clone the recordset object to find the indexes of the table
                     Set rsKeyTemp = rsKey.Clone(adLockReadOnly)
                     rsKeyTemp.Filter 
    = "col2='View'"
                     
    'Set the labelling in the document
                     Call SetHeading("视图:")
                     
    If rsKeyTemp.EOF Then
                         
    Call SetTextAfter("-无-")
                     
    End If
                     
    While Not rsKeyTemp.EOF
                         
    Call SetTextAfter(rsKeyTemp(0))
                         rsKeyTemp.MoveNext
                     
    Wend
                     
                     
    '************************************
                     '******************Stored Procedures***************
                     
                     
    'Clone the recordset object to find the indexes of the table
                     Set rsKeyTemp = rsKey.Clone(adLockReadOnly)
                     rsKeyTemp.Filter 
    = "col2='Stored Procedure'"
                     
    'Set the labelling in the document
                     Call SetHeading("存储过程:")
                     
    If rsKeyTemp.EOF Then
                         
    Call SetTextAfter("-无-")
                     
    End If
                     
    While Not rsKeyTemp.EOF
                         
    Call SetTextAfter(rsKeyTemp(0))
                         rsKeyTemp.MoveNext
                     
    Wend
                     
                     
    '************************************
                     '******************Functions***************
                     
                    
    'Clone the recordset object to find the indexes of the table
                     Set rsKeyTemp = rsKey.Clone(adLockReadOnly)
                     rsKeyTemp.Filter 
    = "col2='Function'"
                     
    'Set the labelling in the document
                     Call SetHeading("用户自定义函数:")
                     
    If rsKeyTemp.EOF Then
                         
    Call SetTextAfter("-无-")
                     
    End If
                     
    While Not rsKeyTemp.EOF
                         
    Call SetTextAfter(rsKeyTemp(0))
                         rsKeyTemp.MoveNext
                     
    Wend
                     
                     
    '************************************
                     '******************Triggers***************
                     
                     
    'Clone the recordset object to find the indexes of the table
                     Set rsKeyTemp = rsKey.Clone(adLockReadOnly)
                     rsKeyTemp.Filter 
    = "col2='Trigger'"
                    
    'Set the labelling in the document
                     Call SetHeading("触发器:")
                     
    If rsKeyTemp.EOF Then
                         
    Call SetTextAfter("-无-")
                     
    End If
                     
    While Not rsKeyTemp.EOF
                         
    Call SetTextAfter(rsKeyTemp(0))
                         rsKeyTemp.MoveNext
                     
    Wend
                
    End If
                
    '************************************
            'Set the labelling in the document
            Call SetHeading("表详细信息")
            
    'Procedure to position the cursor in the document
            Call MoveDown
            
            
    On Error GoTo Err
            
            
    'Query to get the column names of the table
            strQuery = ""
            strQuery 
    = "select st.name,col.*,ex.value from syscolumns col inner join " & _
                       
    " sysobjects sob on col.id = sob.id and sob.XType = 'U' " & _
                       
    " inner join systypes st on col.usertype = st.usertype " & _
                       
    " and col.xtype = st.xtype " & _
                       
    " and sob.Name = '" & rsMain(0& "'" & _
                       
    " inner join sys.extended_properties ex on colid=ex.minor_id and col.id=ex.major_id"
                       
            
    If rsFields.State = 1 Then rsFields.Close
            rsFields.Open strQuery, conn, adOpenKeyset, adLockOptimistic
            
            
    If Not rsFields Is Nothing And rsFields.Fields.Count > 0 Then
                
                
    'Create the table in the document to display the columns
                'Table will display "Field Name","Field Type","Size","Key","Description"
                
                .Tables.Add Range:
    =Selection.Range, NumRows:=rsFields.RecordCount + 1, NumColumns _
                 :
    =6, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
                 wdAutoFitFixed
                 .Tables(row).Cell(
    11).Shading.BackgroundPatternColor = wdColorGray20
                 .Tables(row).Cell(
    11).Range.InsertBefore "字段名"
                 .Tables(row).Cell(
    11).Range.Bold = True
                 .Tables(row).Cell(
    12).Range.InsertBefore "类型"
                 .Tables(row).Cell(
    12).Shading.BackgroundPatternColor = wdColorGray20
                 .Tables(row).Cell(
    12).Range.Bold = True
                 .Tables(row).Cell(
    13).Range.InsertBefore "长度"
                 .Tables(row).Cell(
    13).Shading.BackgroundPatternColor = wdColorGray20
                 .Tables(row).Cell(
    13).Range.Bold = True
                 
    Call .Tables(row).Columns(2).SetWidth(50, wdAdjustSameWidth)
                 
    Call .Tables(row).Columns(3).SetWidth(40, wdAdjustSameWidth)
                 
    Call .Tables(row).Columns(4).SetWidth(40, wdAdjustSameWidth)
                 
    Call .Tables(row).Columns(5).SetWidth(100, wdAdjustSameWidth)
                 
    Call .Tables(row).Columns(6).SetWidth(80, wdAdjustSameWidth)
                 .Tables(row).Cell(
    14).Range.InsertBefore ""
                 .Tables(row).Cell(
    14).Shading.BackgroundPatternColor = wdColorGray20
                 .Tables(row).Cell(
    14).Range.Bold = True
                 .Tables(row).Cell(
    15).Range.InsertBefore "描述"
                 .Tables(row).Cell(
    15).Shading.BackgroundPatternColor = wdColorGray20
                 .Tables(row).Cell(
    15).Range.Bold = True
                 .Tables(row).Cell(
    16).Range.InsertBefore "备注"
                 .Tables(row).Cell(
    16).Shading.BackgroundPatternColor = wdColorGray20
                 .Tables(row).Cell(
    16).Range.Bold = True
                I 
    = 0
                 
    While Not rsFields.EOF
                    .Tables(row).Cell(I 
    + 21).Range.InsertBefore rsFields(1)
                    .Tables(row).Cell(I 
    + 22).Range.InsertBefore rsFields(0)
                    .Tables(row).Cell(I 
    + 23).Range.InsertBefore rsFields(6)
                    
    Dim arr() As String
                    arr 
    = Split(rsFields(33), " ")
                    
    If UBound(arr) = 3 Then
                        .Tables(row).Cell(I 
    + 25).Range.InsertBefore "关联" & arr(2& ""
                    
    Else
                        .Tables(row).Cell(I 
    + 25).Range.InsertBefore rsFields(33)
                    
    End If
                    rsFields.MoveNext
                    I 
    = I + 1
                
    Wend
              
    End If
              
              
    'Query to retrieve the constraints,Keys and Identity of the table
              
             strQuery 
    = "select  c.COLUMN_NAME,CONSTRAINT_TYPE,''  as DefaultValue " & _
                
    " from    INFORMATION_SCHEMA.TABLE_CONSTRAINTS pk ," & _
                
    " INFORMATION_SCHEMA.KEY_COLUMN_USAGE c" & _
                
    " where   pk.TABLE_NAME = '" & rsMain(0& "" & _
                
    " and c.TABLE_NAME = pk.TABLE_NAME" & _
                
    " and c.CONSTRAINT_NAME = pk.CONSTRAINT_NAME" & _
                
    " union" & _
                
    " select c.name,'DEFAULT CONSTRAINT' AS defaultcontraint," & _
                
    " replace(replace(ind.definition,'(',''),')','') AS DefaultValue" & _
                
    " from sys.default_constraints ind" & _
                
    " inner join sys.tables tab" & _
                
    " on ind.parent_object_id = tab.object_id" & _
                
    " inner join sys.columns c" & _
                
    " on tab.object_id = c.object_id and" & _
                
    " c.column_id = ind.parent_column_id" & _
                
    " where tab.name = '" & rsMain(0& "" & _
                
    " union " & _
                
    " select COLUMN_NAME, 'IDENTITY' AS defaultcontraint,''  as DefaultValue " & _
                
    " from INFORMATION_SCHEMA.Columns " & _
                
    " where TABLE_NAME = '" & rsMain(0& "" & _
                
    " and COLUMNPROPERTY(object_id(TABLE_NAME), COLUMN_NAME, 'IsIdentity') = 1"

            
    If rsKey.State = 1 Then rsKey.Close
            rsKey.Open strQuery, conn, adOpenKeyset, adLockOptimistic
            
    If Not rsKey Is Nothing Then
                
    'Iterate through the recordset to find the constraints,Keys and Identity of the table
                While Not rsKey.EOF
                 I 
    = 0
                 rsFields.MoveFirst
                 
    'Iterate throught the fields recordset and set the keys in the 4 and 5 columns of the table
                 Do While Not rsFields.EOF
                    
    If UCase(rsFields(1)) = UCase(rsKey(0)) Then
                        
    If UCase(rsKey(1)) = "FOREIGN KEY" Then
                                .Tables(row).Cell(I 
    + 24).Range.InsertBefore "外键"
                                
    Exit Do
                        
    ElseIf UCase(rsKey(1)) = "PRIMARY KEY" Then
                                .Tables(row).Cell(I 
    + 24).Range.InsertBefore "主键"
                                
    Exit Do
                        
    ElseIf UCase(rsKey(1)) = "DEFAULT CONSTRAINT" Then
                                .Tables(row).Cell(I 
    + 26).Range.InsertBefore "默认" & rsKey(2)
                                
    Exit Do
                        
    ElseIf UCase(rsKey(1)) = "IDENTITY" Then
                                .Tables(row).Cell(I 
    + 26).Range.InsertBefore "标识列"
                                
    Exit Do
                        
    End If
                    
    End If
                    I 
    = I + 1
                    rsFields.MoveNext
                 
    Loop
                    rsKey.MoveNext
                
    Wend
            
    End If
         
         
        
    End With
        row 
    = row + 1
        rsMain.MoveNext
    Wend
    Selection.HomeKey unit:
    =wdStory
    Call InsertDomain
    Selection.TypeParagraph
    Selection.TypeParagraph
    Exit Sub
    Err:
    MsgBox Err.Description
    Call SetHeading("Error in the table: " & rsMain(0))
    Set rsMain = Nothing
    Set rsFields = Nothing
    Set rsKey = Nothing
    End Sub
    Sub MoveDown()
        
    Dim Range3 As Range
        
    Dim I As Integer
        
    On Error Resume Next

        I 
    = ActiveDocument.Tables.Count
        
    Set Range3 = ActiveDocument.Range(Start:=ActiveDocument.Range.End, End:=ActiveDocument.Range.End)
        Range3.MoveEnd unit:
    =wdCharacter, Count:=1
        Range3.SetRange Start:
    =Range3.Start + 2End:=Range3.End
        Range3.Select
        
    With Selection
            .Collapse Direction:
    =wdCollapseEnd
            .TypeParagraph
        
    End With
    End Sub

    Sub SetText(str As String)
        
    Dim Range3 As Range
        
    Dim I As Integer
        
    On Error Resume Next
        I 
    = ActiveDocument.Tables.Count
        
    Set Range3 = ActiveDocument.Range(Start:=ActiveDocument.Tables(I).Range.End, End:=ActiveDocument.Tables(I).Range.End)
        Range3.MoveEnd unit:
    =wdCharacter, Count:=1
        Range3.SetRange Start:
    =Range3.Start + 2End:=Range3.End + Len(str)
        Range3.Select
            
    With Selection
            .Collapse Direction:
    =wdCollapseEnd
            .TypeParagraph
            .InsertParagraph
            .Font.Name 
    = "verdana"
            .Font.Size 
    = 10
            .InsertBefore str
        
    End With
    End Sub

    Sub SetTextAfter(str As String)
        
    Dim Range3 As Range
        
    Dim I As Integer
        
    On Error Resume Next
        I 
    = ActiveDocument.Tables.Count
        
    Set Range3 = ActiveDocument.Range(Start:=ActiveDocument.Range.End, End:=ActiveDocument.Range.End)
        Range3.MoveEnd unit:
    =wdCharacter, Count:=1
        Range3.SetRange Start:
    =Range3.Start + 2End:=Range3.End + Len(str)
        Range3.Select
        
    With Selection
            .Collapse Direction:
    =wdCollapseEnd
            .TypeParagraph
            .Font.Name 
    = "verdana"
            .Font.Size 
    = 10
            .InsertAfter vbTab 
    & str
        
    End With
    End Sub

    Sub SetHeading(str As String)
        
    Dim Range3 As Range
        
    Dim I As Integer
        
    On Error Resume Next
        I 
    = ActiveDocument.Tables.Count
        
    Set Range3 = ActiveDocument.Range(Start:=ActiveDocument.Range.End, End:=ActiveDocument.Range.End)
        Range3.MoveEnd unit:
    =wdCharacter, Count:=1
        Range3.SetRange Start:
    =Range3.Start + 2End:=Range3.End + Len(str)
        Range3.Select
        
        
    With Selection
            .Collapse Direction:
    =wdCollapseEnd
            .TypeParagraph
            .Font.Name 
    = "verdana"
            .Font.Size 
    = 10
            .TypeParagraph
            .Font.Bold 
    = wdToggle
            .Font.ColorIndex 
    = wdGreen
            .TypeText (
    Space(3& str)
            .Font.ColorIndex 
    = wdBlack
            .Font.Bold 
    = wdToggle
        
    End With
    End Sub

    Sub SetTableName(strTable As String, strDescription As String)
        
    Dim Range3 As Range
        
    Dim I As Integer
        
    On Error Resume Next
        I 
    = ActiveDocument.Tables.Count
        
    Set Range3 = ActiveDocument.Range(Start:=ActiveDocument.Tables(I).Range.End, End:=ActiveDocument.Tables(I).Range.End)
        Range3.MoveEnd unit:
    =wdCharacter, Count:=1
        Range3.SetRange Start:
    =Range3.Start + 2End:=Range3.End + Len(strTable)
        Range3.Select
            
    With Selection
            .Collapse Direction:
    =wdCollapseEnd
            .TypeParagraph
            .Font.Name 
    = "verdana"
            .Font.Size 
    = 11
            .Font.Italic 
    = True
            .Font.Bold 
    = wdToggle
            .Font.Color 
    = wdColorDarkRed
            .TypeText strDescription 
    + ": "
            .Font.ColorIndex 
    = wdBlack
            .Font.Bold 
    = wdToggle
            .TypeText strTable
            .Font.Italic 
    = False
            .Paragraphs.OutlineLevel 
    = wdOutlineLevel2
            .TypeParagraph
            .Paragraphs.OutlineLevel 
    = wdOutlineLevelBodyText
        
    End With
    End Sub
    Sub InsertDomain()
    '
    '
     Domain Macro
    '
     宏在 2009-05-08 由 Microsoft USER 录制
    '
        With ActiveDocument
            .TablesOfContents.Add Range:
    =Selection.Range, RightAlignPageNumbers:= _
                
    True, UseHeadingStyles:=True, UpperHeadingLevel:=1, _
                LowerHeadingLevel:
    =3, IncludePageNumbers:=True, AddedStyles:="", _
                UseHyperlinks:
    =True, HidePageNumbersInWeb:=True, UseOutlineLevels:= _
                
    True
            .TablesOfContents(
    1).TabLeader = wdTabLeaderDots
            .TablesOfContents.Format 
    = wdIndexIndent
        
    End With
    End Sub

    转载于:https://www.cnblogs.com/pqmagic/archive/2009/05/08/1452861.html

    展开全文
  • 这里写自定义目录标题欢迎使用Markdown编辑器新的改变功能快捷键合理的创建标题,有助于目录的生成如何改变文本的样式插入链接与图片如何插入一段漂亮的代码片生成一个适合你的列表创建一个表格设定内容居中、居左、...

    序言

    一份word表格,如何快速更改某单元格的内容,比如说序号,或者是填充自己所需要的列表之类的文字,查阅得知
    VBA中的ActiveDocuments.Tables(index)属性,或者使用Python-docx库可以做到。。这篇博客主要记录使用VBA编辑word表格
    在平时的工作的,不建议做没必要的重复性劳动。一是提高工作效率,二是督促自己学习

    正文

    直接步入正题,放出VBA代码:

    i = 2  #2是指表格的数量
    m = 2
    h = 2
    #m,h是指行、列
    #循环读取表格中的单元格,并删除内容
    for j = 1 To i
    ActiveDocument.Tables(j).Cell(m, h).Range.Delete
    Next
    #循环读取表格中的单元格,并填充序号,比如第一个表格(2,2)填充1,第二个表格(2,2)填充2,依次类推
    For k = 1 To i
    ActiveDocument.Tables(k).Cell(3, 1).Range.InsertAfter "" & k
    Next
    

    这套代码只使用于没有干扰性的表格,啥意思呢,就是一个word文档中只有你想更改的表格,没有多余的表格。。单元格索引是从第一个表格开始,一直循环到最后一个表格,,i的数量就是表格的数量

    代码经过在office上的测试,完美运行。

    展开全文
  • 数据源为excel,word中建立表模板,利用邮件合并功能实现批量填表,利用VBA技术将填表结果分成独立的文档
  • 最近在做一个数据分析项目,涉及到生成word文档。py在操作word这一块使用的是python-docx,但是我看了官方文档,发现这个模块并不能生成目录。在查了一些资料后发现win32com能够解决这个问题 使用win32com生成word...
  • VBA操作word生成sql语句

    2017-07-13 09:16:00
    项目开始一般都是用word保存下数据库的文档 但是从表单一个一个的建表实在是很困难乏味,查查资料 1、可以生成一个html或者xml,检索结构生成sql。但是这个方式也蛮麻烦 2、查到vba可以操作word读取表格。所以...
  • 根据word文档修订情况生成清单表格,可运行,非常实用。
  • 关于VBA编辑word自动生成报告

    万次阅读 2016-08-02 20:15:59
    关于VBA编辑word自动生成报告 这适合于图比较多,表比较多,并且报告格式单一,但... 一般word文档中的输入是 图和表,这种方式需要将输入按照对象类型来划分不同的文件夹,通过划分文件类型,降低了对象处理难度.
  • 如果无法确定要使用的 Visual Basic 方法或属性,可打开宏录制器并进行手动操作。宏录制器会将操作译成 Visual Basic 代码。录制操作完成后,可根据需要修改代码。
  • 使用VSTO自动生成word文档

    千次阅读 2012-07-06 16:50:56
    最近第一次用VSTO(Visual Studio Tools For Office),写了一个自动生成word报告的小程序,感觉VSTO非常难用。主要是对office对象模型不熟悉,不理解很多类、方法、属性的含义,word里面很简单的操作却不知道如何...
  • 一、『问题引入』:手里有一个这样的Excel表格,还有一个Word文档模板。我们要把这个Excel表格中的信息依次写到Word模板。一行Excel信息生成一页文档。存储信息的Excel表格需要填入信息的Word文档模板如果手动一条...
  • 最近忙一个小项目,要求根据已有的历史与现状资料填写对照表格,总共有几十份,里面要求填的数据项也很琐碎,而且细节上可能会有小的变更... 既然是access与Word,那就用传说中的VBA咯,但木用过,就上Google猛搜…...
  • 一、『问题引入』:手里有一个这样的Excel表格,还有一个Word文档模板。我们要把这个Excel表格中的信息依次写到Word模板。一行Excel信息生成一页文档。存储信息的Excel表格需要填入信息的Word文档模板如果手动一条...
  • Qt 生成 Word、PPT、PDF 文档

    千次阅读 2019-06-13 15:43:26
    微软的官方文档链接 https://msdn.microsoft.com/zh-cn/vba/word-vba/articles/documents-open-method-word // 代码打印官方帮助文档 // 包含头文件 #include <ActiveQt/QAxObject> // 包含lib Qt5...
  • 不同格式的word文档合并为一个文件。 问题: 文件汇编,需要将70多个文件汇编成一个到一个文件里。最终汇编的方式是用word--插入--对象--文件中的文字。 但是由于原始文件有的设置了自动编号。插入后在合并后的...
  • 用DELPHI怎样生成WORD表格文档

    千次阅读 2012-12-19 09:43:16
     一、VBA代码含义   Microsoft Word是一个集成化环境,是美国微软公司的字处理系统,但是它决不仅仅是一个字处   理系统,它集成了Microsoft Visual Basic,可以通过编程来实现对Word功能的扩展。   ...
  • 昨天和小伙伴们分享了用VBA把Excel的内容写入到Word的表格中,生成一个一个Word的方法...要生成下面的忍者档案,每一个忍者生成一个Word文档,保存在当前文件夹下面第3行的代码,创建Word应用程序对象,相当于启动...
  • 本文实现的是,通过单击VBA按钮,选择一个word批注文件,即可导出该word所有批注,该批注生成excel文件的格式如下: 页码 行号 批注选中的原文字 批注内容 批注作者 下面是代码实现: Sub exportWordComments_...
  • 做了一个多月的C#生成Word文档的工作,我从一开始的对这个一窍不通,到现在的顺利完成...对于用C#来自动生成Word文档来说,最大的问题是微软提供的所有文档的源代码一般都是VBA编程的,没有C#的现成文档,最多也只是...
  • 做了一个多月的C#生成Word文档的工作,我从一开始的对这个一窍不通,到现在的顺利完成了这个功能... 对于用C#来自动生成Word文档来说,最大的问题是微软提供的所有文档的源代码一般都是VBA编程的,没有C#的现成文档,最
  • 做了一个多月的C#生成Word文档的工作,我从一开始的对这个一窍不通,到现在的顺利完成了... 对于用C#来自动生成Word文档来说,最大的问题是微软提供的所有文档的源代码一般都是VBA编程的,没有C#的现成文档,最多也只是
  • 前面和小伙伴们分享了,用office软件自带的邮件合并功能来进行Word与Excel交互,这个邮件合并生成的只有一个Word文档,要想生成一个一个Word文档,就需要用VBA邮件合并-忍者档案今天,就和小伙伴们分享用VBA生成一...
  • WORD vba使用方法

    2010-05-20 20:23:05
    本程序是基于WORD vba自动报告生成的一种方法,能够自动生成word文档,减少办公人员机械的劳动。
  • 本段脚本,可以用来生成一个需求分析文档的提纲: 在上方的“视图→宏(最右边)→查看宏”中,创建一个宏,添加如下代码: '宏名称:DemandAnalysis '宏功能:生成需求分析模版 Sub DemandAn...
  • 学习Excel技术,关注微信公众号:excelperfect示例3:从Excel中提取数据生成不同的Word报表从前面的学习中,我们已经学会了使用书签将Excel中提取的数据放置到文档中指定的位置。下面的示例演示如何运用这些技巧,...
  • Excel批量产生excel或者word,关键两个字批量,速度不是很快,如果数据量多,可以考虑用其他word的邮件功能,这个速度很快,这个VBA重要的是灵活,没有任何限制。

空空如也

空空如也

1 2 3 4 5 ... 8
收藏数 143
精华内容 57
关键字:

vba生成word文档