每个人按模板生成独立工作簿

灵犀之声

数据如图

模板如图

需要每个人生成一张表，对应关系如第7行。用公式带了一组数据做示范。

这个是需要用程序才能完成，求助各位老师，拜谢。使用的是WPS，小花花奉上。

灵犀之声

用公式可以写出一个人的数据，但是要生成每一个人，函数就无法实现啦。

灵犀之声

我只会用公式取数据，代码不会，求教各位大佬。

longwin

请看附件。。。。

灵犀之声

longwin 发表于 2024-7-1 21:44
请看附件。。。。

老师，附件无法打开。

longwin

灵犀之声 发表于 2024-7-1 21:49
老师，附件无法打开。

你是什么版本？

longwin

我这边下载后打开没有问题。
把你的文件里面的模板改成这样：

然后运行下列代码：
Sub test()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
arr = Sheets("1").[a1].CurrentRegion
brr = Sheets("模板").Range("A7:L8")
xm = ""
For i = 2 To UBound(arr)
    If xm <> arr(i, 2) Then
        xm = arr(i, 2)
        For Each sht In Sheets()
            If sht.Name = xm Then sht.Delete
        Next
        Sheets("模板").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        Set sh = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        sh.Name = xm
        sh.[B1] = xm
        l = 7
    End If
    If l > 7 Then
        sh.Rows("7:8").Copy sh.Rows(l & ":" & (l + 1))
        sh.Rows(l & ":" & (l + 1)).ClearContents
    End If
    crr = brr
    For m = 1 To UBound(crr)
        For n = 1 To UBound(crr, 2)
        If crr(m, n) <> "" Then
            ll = crr(m, n)
            crr(m, n) = arr(i, ll)
        End If
        Next
    Next
    sh.Range(Cells(l, 1), Cells(l + 1, 12)) = crr
    l = l + 2
Next

Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "OK!"
End Sub

longwin

这是运行后的结果：

quqiyuan

参与一下。。。供参考。。。

quqiyuan

代码如下。。。

Sub test()
    arr = Sheet1.UsedRange
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
        s = arr(i, 2)
        If s <> "" Then
            If Not d.exists(s) Then Set d(s) = CreateObject("scripting.dictionary")
            d(s)(i) = Application.Index(arr, i)
        End If
    Next
    For Each k In d.keys
        ReDim brr(1 To 10000, 1 To 12)
        n = 0
        Worksheets("模板").Copy After:=Worksheets(Sheets.Count)
        With ActiveSheet
            .[b1] = k
            For Each Item In d(k).items
                n = n + 1
                brr(n, 1) = Item(17)
                brr(n, 2) = Item(8)
                brr(n, 3) = Item(6)
                brr(n, 4) = Item(7)
                brr(n, 5) = Item(10)
                brr(n, 7) = Item(11)
                brr(n, 9) = Item(16)
                brr(n, 11) = Item(15)
                brr(n, 12) = Item(19)
                n = n + 1
                brr(n, 3) = Item(9)
                brr(n, 7) = Item(12)
                brr(n, 11) = Item(13)
                brr(n, 12) = Item(18)
            Next
        .[a7].Resize(n, 12) = brr
        .Name = k
        End With
    Next
    Set d = Nothing
End Sub