请大神帮助word VBA

top396

word 表格灌入数据。

xzcdcak

今天上班不忙，给你作了一个。你看下满意吗？我感觉你要的基本都能实现了。

xzcdcak

我做了个gif你看下。

xzcdcak

刚才太大了。不给上传。看这个吧。希望我的努力没有白费力气。

xzcdcak

写了好半天呢：）
我也刚刚学习这个。

Sub 生成数据_导出docx() 'https://club.excelhome.net/thread-1638040-1-1.html
    Dim i, j, k, arr, brr, x, 设计砼数量, y '车数
    Range("A3:F65535").ClearContents
    Range("B2:F2").ClearContents
    设计砼数量 = Cells(2, 7)
   
    Select Case 设计砼数量
    Case Is < 15
        y = 1  '定出excel有多少行数据
    Case Is = 15
        y = 1
    Case Else
        y = Int(设计砼数量 / 15) + 1 'if int(a/b)*b=a
        If Int(设计砼数量 / 15) * 15 = 设计砼数量 Then
            y = 设计砼数量 / 15
        Else
            y = Int(设计砼数量 / 15) + 1
        End If
    End Select
   
   
    ReDim arr(1 To y, 1 To 6)
    If 设计砼数量 > 15 Then
        For i = 1 To y
            If i = 1 Then
                arr(i, 1) = Cells(2, 1)
                arr(i, 2) = 1
                arr(i, 3) = Application.RandBetween(160, 180)
                arr(i, 4) = 15
                arr(i, 5) = 15
                arr(i, 6) = "无"
            Else
                If Not i = y Then
                    arr(i, 1) = arr(i - 1, 1) + TimeValue("0:15:23")
                    arr(i, 2) = arr(i - 1, 2) + 1
                    arr(i, 3) = Application.RandBetween(160, 180)
                    arr(i, 4) = 15
                    arr(i, 5) = arr(i - 1, 5) + 15
                    arr(i, 6) = "无"
                Else
                    arr(i, 1) = arr(i - 1, 1) + TimeValue("0:15:23")
                    arr(i, 2) = arr(i - 1, 2) + 1
                    arr(i, 3) = Application.RandBetween(160, 180)
                    arr(i, 4) = 设计砼数量 - arr(i - 1, 5)
                    arr(i, 5) = 设计砼数量
                    arr(i, 6) = "无"
                End If
            End If
        Next
        Range("A2").Resize(UBound(arr) - LBound(arr) + 1, UBound(arr, 2) - LBound(arr, 2) + 1) = arr
        
    Else
        Cells(2, 2) = 1
        Cells(2, 3) = Application.RandBetween(160, 180)
        Cells(2, 4) = 设计砼数量
        Cells(2, 5) = 设计砼数量
        Cells(2, 6) = "无"
         
    End If
   
    If y <= 20 Then
        页数word = 1
    Else
        If Int(y / 20) * 20 = y Then
            页数word = y / 20
        Else
            页数word = Int(y / 20) + 1
        End If    '每次页20行数据表
    End If
   
    '————————————————————————以上产生数据
    '————————————————————————以下生成word
    Dim Wrd对象 As Object
    Set Wrd对象 = CreateObject("Word.Application")
    Dim 当前路径, 导出文件名, 导出路径文件名, 判断
    Dim Str1, Str2
    当前路径 = ThisWorkbook.Path
'    最后行号 = Sheets("数据").Range("B65536").End(xlUp).Row
'    判断 = 0
    导出文件名 = "混凝土浇筑记录" & Format(Now, "yyyymmddhhmmss") & ".docx"
    导出路径文件名 = 当前路径 & "\" & 导出文件名
    FileCopy 当前路径 & "\混凝土浇筑记录（样表）.docx", 导出路径文件名
    With Wrd对象
        .Documents.Open 导出路径文件名
        .Visible = False
        .ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument '设置位置在正文
        Str1 = "数据001"
        Str2 = CStr(设计砼数量) 'Sheets("数据").Cells(2, 6)
        
       .Selection.HomeKey Unit:=wdStory '光标置于文件首
      If .Selection.Find.Execute(Str1) Then '查找到指定字符串
         .Selection.Font.Color = wdColorAutomatic '字符为自动颜色
         .Selection.Text = Str2 '替换字符串
      End If
      
        .ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument '设置位置在正文
        .Selection.WholeStory '全选
        .Selection.Copy '复制
        If 页数word > 1 Then '''''''''''''''''''''''''''''''''''''''''''？？？？？
            For i = 2 To 页数word '复制页
                .Selection.EndKey Unit:=wdStory, Extend:=wdExtend
                .Selection.MoveDown Unit:=wdLine, Count:=1 '光标置于文件尾
                .Selection.InsertBreak Type:=0 '分页
                .Selection.PasteAndFormat (wdFormatOriginalFormatting) '粘贴
                Next i
        End If
            
                m = 2 '标记要读第几行excel
                For i = 1 To 页数word '填写表格数据
                  For j = 1 To 20 '''''''''''''
                     For k = 1 To 6
                     .ActiveDocument.Tables(i).Cell(j + 6, k).Range = Sheets("数据").Cells(m, k).Text
                     
                    Next k
                    m = m + 1
                    Next j
                    Next i
                    
                    
         
                    
                    
                    
                    
                    
                    
                    
                    End With
                    Wrd对象.Documents.Save
                    Wrd对象.Quit
                    Set Wrd对象 = Nothing
                    If 判断 = 0 Then
                        i = MsgBox("已生成“" & 导出路径文件名 & "”！", 0 + 48 + 256 + 0, "提示：")
                    End If
                    
                    
                    
                    
                    
                    
                    End Sub
                    

413191246se

xzcdcak 发表于 2022-9-8 20:36
写了好半天呢：）
我也刚刚学习这个。

新人朋友刚来就展现了无比优秀的才华！令人佩服啊！还会数组！

xzcdcak

小改了一下。时间间隔是15-17分钟随机的。这样更好：）

xzcdcak

看来我是白写了：（

413191246se

新人朋友，别气馁！坚持下去，一个是锻炼自己，一个是帮助他人，你的编程水平会得到提高的，重在参与！乐在其中（有时我也是这样，写了好半天发布后，楼主好久不回复）。

xzcdcak

413191246se 发表于 2022-9-18 23:52
新人朋友，别气馁！坚持下去，一个是锻炼自己，一个是帮助他人，你的编程水平会得到提高的，重在参与！乐在 ...

看他附件里写的言辞恳切，想我哪天也没事 。就给他写了。结果人家根本不是很需要的样子。确实有点我本将心向明月的感觉 。但是自己确实是更能力强了。