按模板生成在一个表格

灵犀之声

求助各位大佬，类似于Word的邮件目录形式，把所有的数据按模板生成在一个表格里面，每一条之间空一行。

表1的数字是模板里面的顺序，拜谢各位大佬。

灵犀之声

恭请论坛大佬，大展神威，小花感谢！！！

cidanji

批量生成在一个表格.zip (29.95 KB, 下载次数: 35)

2024-1-3 17:54 上传

点击文件名下载附件

duest

Sub test()
Dim arr, brr
    With Sheets("数据")
       .Rows("1:1").Delete Shift:=xlUp
        arr = .UsedRange
    End With
    '每行单独写入数组BRR
    With Sheets("模板")
    brr = .Range("A1:B9")
        For i = 2 To UBound(arr, 1)
            brr(1, 2) = arr(i, 1)
            brr(2, 2) = arr(i, 2)
            brr(3, 2) = arr(i, 3)
            brr(4, 2) = arr(i, 13)
            brr(5, 2) = arr(i, 14)
            brr(6, 2) = arr(i, 9)
            brr(7, 2) = arr(i, 7)
            brr(8, 2) = arr(i, 6)
            brr(9, 2) = arr(i, 8)
            '.Cells(10 * (i - 2) + 1, 1).Select
            .Cells(10 * (i - 2) + 1, 1).Resize(9, 2) = brr
        Next
    End With
End Sub

duest

Sub test()
Dim arr, brr
    With Sheets("数据")
       .Rows("1:1").Delete Shift:=xlUp
        arr = .UsedRange
    End With
    '每行单独写入数组BRR
    With Sheets("模板")
    brr = .Range("A1:B9")
        For i = 2 To UBound(arr, 1)
            brr(1, 2) = arr(i, 1)
            brr(2, 2) = arr(i, 2)
            brr(3, 2) = arr(i, 3)
            brr(4, 2) = arr(i, 13)
            brr(5, 2) = arr(i, 14)
            brr(6, 2) = arr(i, 9)
            brr(7, 2) = arr(i, 7)
            brr(8, 2) = arr(i, 6)
            brr(9, 2) = arr(i, 8)
            '.Cells(10 * (i - 2) + 1, 1).Select
            .Cells(10 * (i - 2) + 1, 1).Resize(9, 2) = brr
        Next
    End With
End Sub

乐铁松

灵犀之声 发表于 2024-1-3 17:25
恭请论坛大佬，大展神威，小花感谢！！！

这样的表格，完全可以用WORD的电子邮件功能来实现。

灵犀之声

cidanji 发表于 2024-1-3 17:54

感谢老师，但是有一个问题，发行区间里面有些会强制转换为日期格式，比如3 - 4这样的，直接就转成3月4日了。

cidanji

灵犀之声 发表于 2024-1-3 22:40
感谢老师，但是有一个问题，发行区间里面有些会强制转换为日期格式，比如3 - 4这样的，直接就转成3月4日 ...

可以使用前先把这列设置为文本格式

duest

Cells(10*（i-2）+9, 2).NumberFormat = "@" ' 将单元格格式设置为文本

E花E世界

1. Sub 批量生成简表()
   
2. Dim arr, brr, crr
   
3.     arr = Sheets(1).Range("A1").CurrentRegion
   
4.     brr = Array("债券:", "发行人:", "发行日:", "缴款日:", "上市日:", "主体评级:", "规模(亿):", "期限:", "发行区间:")
   
5.     crr = Array(1, 2, 3, 13, 14, 9, 7, 6, 8)
   
6. ReDim drr(1 To (UBound(arr) - 1) * 10, 1 To 2)
   
7.     For i = 1 To UBound(arr) - 2
   
8.         For j = 0 To UBound(brr)
   
9.         drr(10 * i - 9 + j, 1) = brr(j)
   
10.         drr(10 * i - 9 + j, 2) = arr(i + 2, crr(j))
    
11.     Next
    
12. Next
    
13. Sheet2.Range("A:B").ClearContents
    
14. Sheet2.Range("A1").Resize(UBound(drr), 2) = drr
    
15. End Sub
    

复制代码