小白求助大神，按模板批量生成申请表

灵犀之声

我需要将数据源里面的数据填入到模板里面，每一条批量生成单独的Excel表格，本人VBA小白一个，求大神帮助，谢谢。

3190496160

Sub 申请表()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set sh = Sheets("模板")
With Sheets("数据源")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:p" & r)
End With
For i = 2 To UBound(ar)
    If Trim(ar(i, 4)) <> "" Then
        sh.Copy
        Set wb = ActiveWorkbook
        With wb.Worksheets(1)
            .Name = ar(i, 1)
            .[c4] = ar(i, 4)
            .[e4] = ar(i, 5)
            .[g4] = ar(i, 6)
            .[c5] = ar(i, 7)
            .[e5] = ar(i, 8)
            
            .[c6] = ar(i, 10)
            .[e6] = ar(i, 11)
            .[g6] = ar(i, 12)
            .[c7] = ar(i, 13)
            .[e7] = ar(i, 14)
            
            .[b8] = ar(i, 9)
            .[b9] = ar(i, 15)
        End With
        wb.SaveAs Filename:=ThisWorkbook.Path & "\申请表存放\" & ar(i, 1) & ".xlsx"
        wb.Close
    End If
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

批量生成.rar (20.43 KB, 下载次数: 48)

2023-6-20 11:09 上传

点击文件名下载附件

洋务德雷

有用给个鲜花！

sxbjzjf110

参与一下。。。。。

lcluck2002

参与一下。
批量生成0620

熊文来

好帖子，我以前也经常遇到这类问题。

yynrzwh

1. Sub 批量生产申请表()
   
2. 
   
3. arr = Sheets("数据源").Range("A1").CurrentRegion
   
4. 
   
5.     For i = 2 To UBound(arr)
   
6.         Sheets("模板").Copy
   
7.         With Sheets("模板")
   
8.             r = Val(Left(arr(i, 2), 1))
   
9.                 .[b2] = "大赛报名表（类别：" & arr(i, 3) & "）"
   
10.                 .[c4] = arr(i, 4)
    
11.                 .[e4] = arr(i, 5)
    
12.                 .[g4] = arr(i, 6)
    
13.                 .[c5] = arr(i, 7)
    
14.                 .[e5] = "'" & Replace(arr(i, 8), "[身份证]", "")
    
15.                 .[b8] = arr(i, 9)
    
16.                 If r = 2 Then
    
17.                     .[c6] = arr(i, 10)
    
18.                     .[e6] = arr(i, 11)
    
19.                     .[g6] = arr(i, 12)
    
20.                     .[c7] = arr(i, 13)
    
21.                     .[e7] = "'" & Replace(arr(i, 14), "[身份证]", "")
    
22.                     .[b9] = arr(i, 15)
    
23.                 End If
    
24.             ActiveWorkbook.SaveAs ThisWorkbook.Path & "\申请表存放" & arr(i, 1) & ".xlsx"
    
25.             ActiveWorkbook.Close
    
26.         End With
    
27.     Next i
    
28.    
    
29. 
    
30. End Sub

复制代码

lizhipei78

这个不是邮件合并就解决了么