Vba 如何循环遍历一系列数据，为数据中的每个唯一ID复制模板，并填写模板

我正试图编写一个VBA脚本来对客户机列表进行排序，其中每个客户机（每行一个）都有一个特定的组名。每个组有多个客户端。宏应：

• 将每个唯一组的模板表单复制到新选项卡中
• 使用组名重命名选项卡
• 在小组表格中填写小组每个成员的信息
• 转到下一个组并重复此过程，直到所有组都有自己的选项卡，其中包含组中每个客户端的相关信息

我让宏重复这个过程一次，但在第二次复制模板后它停止了，并且没有根据组名重命名选项卡。也许我遗漏了一个简单的循环语句？代码如下。谢谢

 Sub ContractPopulate()

 Dim wrk As Workbook
 Dim trg As Worksheet
 Dim datasheet As Worksheet
 Dim TRow As Long
 Dim BRow As Long
 Dim C_PR As Range
 Dim GrpCnt As Long
 Dim rng As String
 Dim rngcnt As Range


Application.ScreenUpdating = False

Set wrk = ActiveWorkbook 'Working in active workbook
TRow = 2 'Start at the first group
Set datasheet = wrk.Worksheets("Data")

Sheets("Contract").Select
Sheets("Contract").Copy After:=wrk.Worksheets(wrk.Worksheets.Count)
Set trg = wrk.ActiveSheet
trg.Copy After:=wrk.Worksheets(wrk.Worksheets.Count)
trg.Name = datasheet.Cells(TRow, 8).Value

GrpCnt = 0 'Reset group count to 0 -to begin counting groups?

 'Copy FO, paste to row 7, column B
Set C_PR = datasheet.Range(datasheet.Cells(TRow, 6), datasheet.Cells(TRow, 6))
trg.Cells(7, 2) = C_PR.Value

 'Copy group name, paste row 7, column W
Set C_PR = datasheet.Range(datasheet.Cells(TRow, 8), datasheet.Cells(TRow, 8))
trg.Cells(7, 23) = C_PR.Value

 'Copy cell name, paste row 8, column B
Set C_PR = datasheet.Range(datasheet.Cells(TRow, 5), datasheet.Cells(TRow, 5))
trg.Cells(8, 2) = C_PR.Value

'Copy unique group ID to row 8, coulmn U (hidden by white text)
Set C_PR = datasheet.Range(datasheet.Cells(TRow, 7), datasheet.Cells(TRow, 7))
trg.Cells(8, 21) = C_PR.Value

 'Count groups again?
rng = datasheet.Cells(TRow, 7).Value


 Do While rng = trg.Cells(8, 21) 'Uses the hidden Unique Group Name to count the number of clients to enter from datasheet

 'Copying client last name and dropping it in worksheet row one down from top, column H
Set C_PR = datasheet.Range(datasheet.Cells(TRow, 9), datasheet.Cells(TRow, 9))
trg.Cells(12 + (TRow - 1) * 3, 8) = C_PR.Value

 'Copying client first name and dropping it in worksheet row trow one down from top, column T
Set C_PR = datasheet.Range(datasheet.Cells(TRow, 10), datasheet.Cells(TRow, 10))
trg.Cells(12 + (TRow - 1) * 3, 20) = C_PR.Value

 'Copy National ID
Set C_PR = datasheet.Range(datasheet.Cells(TRow, 13), datasheet.Cells(TRow, 13))
trg.Cells(13 + (TRow - 1) * 3, 4) = C_PR.Value

 Set C_PR = datasheet.Range(datasheet.Cells(TRow, 14), datasheet.Cells(TRow, 14))
trg.Cells(13 + (TRow - 1) * 3, 5) = C_PR.Value

 Set C_PR = datasheet.Range(datasheet.Cells(TRow, 15), datasheet.Cells(TRow, 15))
trg.Cells(13 + (TRow - 1) * 3, 6) = C_PR.Value

'Find next line in the group from the top row
TRow = TRow + 1
rng = datasheet.Cells(TRow, 7).Value


Set rngcnt = datasheet.Range(datasheet.Cells(2, 7), datasheet.Cells(65536, 7).End(xlUp))
BRow = rngcnt.Rows.Count


Loop


End Sub

轻度测试

Sub ContractPopulate()

 Const START_ROW As Long = 2

 Dim wrk As Workbook
 Dim trg As Worksheet
 Dim datasheet As Worksheet
 Dim rwSrc As Range, grp As String, dRow As Long

    Set wrk = ActiveWorkbook 'Working in active workbook
    Set datasheet = wrk.Worksheets("Data")

    Set rwSrc = datasheet.Rows(START_ROW)

    Do While rwSrc.Cells(8).Value <> ""

        grp = rwSrc.Cells(8).Value

        'see if we already have a sheet for this group...
        Set trg = Nothing
        On Error Resume Next
        Set trg = wrk.Sheets(grp)
        On Error GoTo 0

        'no sheet created yet, so create it and set it up
        If trg Is Nothing Then
            Sheets("Contract").Copy After:=wrk.Worksheets(wrk.Worksheets.Count)
            Set trg = wrk.Worksheets(wrk.Worksheets.Count)
            trg.Name = grp
            'one-time copy of values....
            trg.Cells(7, 2).Value = rwSrc.Cells(6).Value
            trg.Cells(7, 23).Value = grp
            trg.Cells(8, 2).Value = rwSrc.Cells(5).Value
            trg.Cells(8, 21).Value = rwSrc.Cells(7).Value
        End If

        'copy the rest of the values...

        'not quite sure how your template is laid out
        '  so you may need to adjust this next line
        dRow = trg.Cells(Rows.Count, 8).End(xlUp).Row + 3

        If dRow < 13 Then dRow = 13

        trg.Cells(dRow, 8).Value = rwSrc.Cells(9).Value
        trg.Cells(dRow, 20).Value = rwSrc.Cells(10).Value
        trg.Cells(dRow + 1, 4).Value = rwSrc.Cells(13).Value
        trg.Cells(dRow + 1, 5).Value = rwSrc.Cells(14).Value
        trg.Cells(dRow + 1, 6).Value = rwSrc.Cells(15).Value

        Set rwSrc = rwSrc.Offset(1, 0)
    Loop

End Sub

subcontractPopulate（）
Const START_行的长度=2
将工作文件作为工作簿
Dim trg As工作表
将数据表设置为工作表
尺寸rwSrc作为范围，grp作为字符串，dRow作为长度
设置wrk=ActiveWorkbook'在活动工作簿中工作
设置数据表=工作表（“数据”）
Set rwSrc=数据表.Rows（开始行）
Do While rwSrc.Cells（8）.Value“”
grp=rwSrc.单元（8）.值
'看看我们是否已经有了此组的工作表。。。
设置trg=Nothing
出错时继续下一步
设置试验=工作表（grp）
错误转到0
'尚未创建图纸，因此请创建并设置它
如果trg什么都不是，那么
工作表（“合同”）。之后的副本：=工作表（工作表计数）
设置trg=wrk.Worksheets（wrk.Worksheets.Count）
trg.Name=grp
'值的一次性副本。。。。
训练单元（7,2）.Value=rwSrc.Cells（6）.Value
训练单元（7，23）。数值=grp
训练单元（8,2）.Value=rwSrc.Cells（5）.Value
训练单元（8,21）.Value=rwSrc.Cells（7）.Value
如果结束
'复制其余的值。。。
'不太确定模板的布局
'因此，您可能需要调整下一行
dRow=trg.Cells（Rows.Count，8）。End（xlUp）。Row+3
如果dRow<13，则dRow=13
训练单元（dRow，8）.Value=rwSrc.Cells（9）.Value
训练单元（dRow，20）.Value=rwSrc.Cells（10）.Value
训练单元（dRow+1,4）.Value=rwSrc.Cells（13）.Value
训练单元（dRow+1,5）.Value=rwSrc.Cells（14）.Value
训练单元（dRow+1,6）.Value=rwSrc.Cells（15）.Value
设置rwSrc=rwSrc.Offset（1,0）
环
端接头