根据sheet1数据自动生成N个表2

乐彩007

Sub 拆分()
    Dim arr As Variant, zd
    Application.ScreenUpdating = False
    arr = Sheet1.UsedRange
    Set zd = CreateObject("scripting.dictionary")
    For i = 3 To UBound(arr) Step 2
        zd(arr(i, 2) & "|" & arr(i + 1, 2) & "|" & arr(i + 1, 4)) = zd(arr(i, 2) & "|" & arr(i + 1, 2) & "|" & arr(i + 1, 4)) + 1
    Next
    For Each sht In zd.keys
        k = k + 1
        Sheets("见证记录").Copy Sheets(Sheets.Count)
        With ActiveSheet
            .Name = k & "." & Split(sht, "|")(0)
            .Range("C1") = WorksheetFunction.Text(k, "000")
            .Range("E6") = Split(sht, "|")(1)
            .Range("F6") = zd(sht)
            .Range("G7") = Split(sht, "|")(2)
            .Range("E12") = Split(sht, "|")(2)
        End With
    Next
    Set zd = Nothing
    Application.ScreenUpdating = True
End Sub

edwin11891

乐彩007 发表于 2024-11-25 21:46
这里有一个VBA，可是年头太多了，我也不会用了

那个不是完成这个功能的，表名称也不对了。
如果不是每项都要制作成独立的表，而是打印的话，可以在F7设置公式：
=INDEX(sheet1!B2:B100,Z4*1)
这样，只要在Z4输入编号，即可得出相应验收部位，很简单。逐份打印即可。

dambcer

。。。。。。。。。。。。。。。。。。

乐彩007

edwin11891 发表于 2024-11-25 21:57
那个不是完成这个功能的，表名称也不对了。
如果不是每项都要制作成独立的表，而是打印的话，可以在F7设 ...

表会有很多，且需要保存，所以需要生成独立sheetf才行，之前我上传的确实与这个无关

mykitami

WORD有个邮件合并功能很适合干这个

乐彩007

mykitami 发表于 2024-11-26 07:34
WORD有个邮件合并功能很适合干这个

大神指点下，我小白，能帮我实现一下吗？

你是那块小饼干

打不开附件

你是那块小饼干

用邮件合并 或者 易用宝的标签打印功能

袁勇

乐彩007 发表于 2024-11-26 06:04
表会有很多，且需要保存，所以需要生成独立sheetf才行，之前我上传的确实与这个无关

是需要生成独立sheet，还是需要生成独立book ?

lanjian229

易用宝还是很实用的