根据模板批量填写

荷氏娱乐秀

根据模板批量填写 社区调查.rar (325 Bytes, 下载次数: 0)

2026-4-25 19:40 上传

点击文件名下载附件

不与饭圈理论

刘汐悦

附件供参考。。。

社区调查.zip (57.6 KB, 下载次数: 0)

2026-4-25 19:40 上传

点击文件名下载附件

北极虎

• Sub ykcbf()          '2026.1.27
  
•     ApplicationSettings False
  
•     arr = Range("a1").CurrentRegion.Value
  
•     Dim tm: tm = Timer
  
•     Dim zrr As New Collection
  
•     r1 = 0: r2 = 0
  
•     For i = 2 To UBound(arr)
  
•         If arr(i, 13) Like "*户主*" Then
  
•             If r1  0 Then zrr.Add Array(r1, r2)
  
•             r1 = i
  
•         End If
  
•         If r1  0 Then r2 = i
  
•     Next i
  
•     If r1  0 Then zrr.Add Array(r1, r2)
  
•     xm = "人口基础信息采集表"
  
•     p = ThisWorkbook.Path & Application.PathSeparator
  
•     fn = p & xm & ".docx"
  
•     b = Array(0, 0, 13, 2, 4, 7, 8, 9, 10)
  
•     Set doc = GetWordApplication()
  
•     On Error Resume Next
  
•     For x = 1 To zrr.Count
  
•         r1 = zrr(x)(0): r2 = zrr(x)(1)
  
•         f = p & xm & "（" & arr(r1, 2) & "）.docx"
  
•         CreateObject("Scripting.FileSystemObject").CopyFile fn, f, True
  
•         With doc.Documents.Open(f)
  
•             With .Tables(1)
  
•                 .cell(2, 2).Range.Text = arr(r1, 2)
  
•                 .cell(2, 4).Range.Text = arr(r1, 3)
  
•                 .cell(2, 6).Range.Text = Format(arr(r1, 5), "yyyy年m月")
  
•                 .cell(3, 2).Range.Text = arr(r1, 6)
  
•                 .cell(3, 4).Range.Text = arr(r1, 7)
  
•                 .cell(3, 6).Range.Text = arr(r1, 15)
  
•                 .cell(5, 2).Range.Text = arr(r1, 8)
  
•                 .cell(5, 4).Range.Text = arr(r1, 4)
  
•                 .cell(6, 2).Range.Text = arr(r1, 12)
  
•                 .cell(7, 2).Range.Text = arr(r1, 9)
  
•                 .cell(7, 4).Range.Text = arr(r1, 10)
  
•                 m = 8
  
•                 For i = r1 To r2
  
•                     m = m + 1
  
•                     For j = 2 To 8
  
•                         .cell(m, j).Range.Text = arr(i, b(j))
  
•                     Next
  
•                 Next
  
•             End With
  
•             .SaveAs2 Filename:=f, FileFormat:=16
  
•             .Close
  
•         End With
  
•     Next
  
•     On Error GoTo 0
  
•     doc.Quit: Set doc = Nothing
  
•     ApplicationSettings True
  
•     MsgBox "共用时：" & Format(Timer - tm, "0.000") & " 秒！" & vbCrLf & _
  
•         "成功生成了：" & zrr.Count & " 个文件。", vbInformation, "操作完成"
  
• End Sub
  
• 
  
• Function GetWordApplication() As Object
  
•     On Error Resume Next
  
•     Set GetWordApplication = GetObject(, "Word.Application")
  
•     If Err.Number  0 Then
  
•         Err.Clear
  
•         Set GetWordApplication = CreateObject("Word.Application")
  
•     End If
  
•     On Error GoTo 0
  
•     If Not GetWordApplication Is Nothing Then
  
•         GetWordApplication.Visible = False
  
•     End If
  
• End Function
  
• 
  
• Private Sub ApplicationSettings(ByVal Reset As Boolean)
  
•     With Application
  
•         .ScreenUpdating = Reset
  
•         .DisplayAlerts = Reset
  
•         .Calculation = IIf(Reset, xlCalculationAutomatic, xlCalculationManual)
  
•         .AskToUpdateLinks = Reset
  
•         .EnableEvents = Reset
  
•     End With
  
• End Sub
  

边角料小百科

各位老师还有什么好的办法和代码吗

坏坏惹人爱

帮忙看看，我的帖子，谢谢了
随机填充没法安条件填充时，提示并退出程序-Excel VBA程序开发-ExcelHome技术论坛 - https://club.excelhome.net/threa ... tml?_dsign=79078d8f

天堂里的死猪

Sub 填充人口信息采集()
    Dim wsSource As Worksheet
    Dim docTarget As Object ' Word文档对象
    Dim appWord As Object ' Word应用程序对象
    Dim docTemplatePath As String
    Dim lastRow As Long, i As Long
    Dim householdStart As Long, householdEnd As Long
    Dim fileCount As Long
    Dim outputFolder As String
   
    ' 设置文件路径（当前文件已经是网格名单.xlsm）
    docTemplatePath = ThisWorkbook.Path & "\人口基础信息采集表.docx"
    outputFolder = ThisWorkbook.Path & "\生成结果\"
   
    ' 检查模板文件是否存在
    If Dir(docTemplatePath) = "" Then
        MsgBox "找不到文件：人口基础信息采集表.docx", vbExclamation
        Exit Sub
    End If
   
    ' 设置源工作表
    Set wsSource = ThisWorkbook.Sheets(1) ' 假设数据在第一个工作表
   
    ' 创建输出文件夹
    On Error Resume Next
    MkDir outputFolder
    On Error GoTo 0
   
    ' 检查文件夹是否创建成功
    If Dir(outputFolder, vbDirectory) = "" Then
        MsgBox "无法创建输出文件夹：" & outputFolder, vbExclamation
        Exit Sub
    End If
   
    ' 获取最后一行
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
   
    ' 启动Word应用程序
    On Error Resume Next
    Set appWord = GetObject(, "Word.Application")
    If Err.Number  0 Then
        Set appWord = CreateObject("Word.Application")
    End If
    On Error GoTo 0
   
    appWord.Visible = False
   
    ' 初始化计数器
    fileCount = 0
    householdStart = 0
   
    ' 遍历所有行，查找户主
    For i = 2 To lastRow
        If Trim(wsSource.Cells(i, 13).Value) = "户主" Then
            ' 如果找到前一个户主的结束位置
            If householdStart > 0 Then
                householdEnd = i - 1
                Call 填充单个家庭(wsSource, appWord, docTemplatePath, householdStart, householdEnd, outputFolder)
                fileCount = fileCount + 1
            End If
            householdStart = i
        End If
    Next i
   
    ' 处理最后一个家庭
    If householdStart > 0 Then
        householdEnd = lastRow
        Call 填充单个家庭(wsSource, appWord, docTemplatePath, householdStart, householdEnd, outputFolder)
        fileCount = fileCount + 1
    End If
   
    ' 清理资源
    appWord.Quit
    Set appWord = Nothing
   
    Application.ScreenUpdating = True
    MsgBox "处理完成！共生成 " & fileCount & " 个家庭的信息采集表。" & vbCrLf & _
           "文件保存在：" & outputFolder, vbInformation
End Sub

Sub 填充单个家庭(wsSource As Worksheet, appWord As Object, docTemplatePath As String, startRow As Long, endRow As Long, outputFolder As String)
    Dim docTarget As Object
    Dim table As Object
    Dim householdName As String, fileName As String, targetPath As String
    Dim i As Long, rowIndex As Long
    Dim birthDate As Date
    Dim familyMemberCount As Long
   
    On Error GoTo ErrorHandler
   
    ' 获取户主姓名（第2列）
    householdName = Trim(wsSource.Cells(startRow, 2).Value)
    If householdName = "" Then
        Exit Sub ' 如果户主姓名为空，跳过
    End If
   
    ' 清理文件名中的非法字符
    householdName = CleanFileName(householdName)
   
    ' 生成文件名和路径
    fileName = "人口基础信息采集表_" & householdName & ".docx"
    targetPath = outputFolder & fileName
   
    ' 检查文件是否已存在
    If Dir(targetPath)  "" Then
        ' 如果文件已存在，添加时间戳
        fileName = "人口基础信息采集表_" & householdName & "_" & Format(Now, "yyyymmdd_hhmmss") & ".docx"
        targetPath = outputFolder & fileName
    End If
   
    ' 复制模板文件
    FileCopy docTemplatePath, targetPath
   
    ' 打开Word文档
    Set docTarget = appWord.Documents.Open(targetPath)
   
    ' 获取文档中的第一个表格
    Set table = docTarget.Tables(1)
   
    ' 计算家庭成员数量
    familyMemberCount = endRow - startRow + 1
   
    ' 填充户主信息
    With wsSource
        ' 基本信息区
        table.Cell(2, 2).Range.Text = .Cells(startRow, 2).Value ' 姓名
        table.Cell(2, 4).Range.Text = .Cells(startRow, 3).Value ' 性别
        
        ' 处理出生日期格式
        If IsDate(.Cells(startRow, 5).Value) Then
            birthDate = .Cells(startRow, 5).Value
            table.Cell(2, 6).Range.Text = Format(birthDate, "yyyy年m月")
        Else
            table.Cell(2, 6).Range.Text = .Cells(startRow, 5).Value
        End If
        
        table.Cell(3, 2).Range.Text = .Cells(startRow, 6).Value ' 民族
        table.Cell(3, 4).Range.Text = .Cells(startRow, 7).Value ' 户籍地
        table.Cell(3, 6).Range.Text = .Cells(startRow, 15).Value ' 联系方式
        
        table.Cell(5, 2).Range.Text = .Cells(startRow, 8).Value ' 政治面貌
        table.Cell(5, 4).Range.Text = .Cells(startRow, 4).Value ' 公民身份号码
        table.Cell(6, 2).Range.Text = .Cells(startRow, 12).Value ' 家庭住址
        table.Cell(7, 2).Range.Text = .Cells(startRow, 9).Value ' 是否外出务工
        table.Cell(7, 4).Range.Text = .Cells(startRow, 10).Value ' 工作/学习单位
    End With
   
    ' 填充家庭成员信息（从第9行开始）
    rowIndex = 9
    For i = startRow To endRow
        If rowIndex  100 Then
        fileName = Left(fileName, 100)
    End If

    CleanFileName = fileName
End Function

科学胜

根据模板批量填写（excel数据写入word) 根据模板批量填写（excel数据写入word).rar (68.99 KB, 下载次数: 0)

2026-4-25 19:40 上传

点击文件名下载附件

为者长成

ai写比较复杂

守一明法

是的，定义变量也很长。