以下代码需要修改，1.目前只复制一行到新建的excel，需要复制所有B列重复值的行到对应新建的excel，If Not dict.Exists(name) Then '判断字典中是否存在当前姓名，不存在则继续 dict.Add name, True '将当前姓名加入字典，值为True filePath = ThisWorkbook.Path & "\" & name & ".xlsx" '生成当前姓名对应的文件路径 Dim newWorkbook As Workbook '定义变量newWorkbook为工作簿类型，用于新建工作簿 Set newWorkbook = Workbooks.Add '新建工作簿 '复制表2中与当前姓名相同的行，并粘贴到新建的工作簿A2单元格 ws2.Range("A1:R1").Copy newWorkbook.Sheets(1).Range("A1:R1") ws2.Range("B" & k & ":R" & k).Copy newWorkbook.Sheets(1).Range("A2") newWorkbook.SaveAs fileName:=filePath '保存工作簿 newWorkbook.Close SaveChanges:=False '关闭工作簿 End If

以下是修改后的代码，实现复制所有B列重复值的行到对应新建的excel：

Dim dict As Object '定义变量dict为对象类型，用于创建字典
Set dict = CreateObject("Scripting.Dictionary") '创建字典

Dim lastRow As Long '定义变量lastRow为长整型，用于存储表2最后一行的行号
lastRow = ws2.Cells(Rows.Count, "B").End(xlUp).Row '获取表2最后一行的行号

Dim i As Long '定义变量i为长整型，用于遍历表2中的所有行
For i = 2 To lastRow '从表2第2行开始遍历
    Dim name As String '定义变量name为字符串类型，用于存储当前行的姓名
    name = ws2.Cells(i, "B").Value '获取当前行的姓名

    If Not dict.Exists(name) Then '判断字典中是否存在当前姓名，不存在则继续
        dict.Add name, True '将当前姓名加入字典，值为True
        Dim filePath As String '定义变量filePath为字符串类型，用于存储当前姓名对应的文件路径
        filePath = ThisWorkbook.Path & "\" & name & ".xlsx" '生成当前姓名对应的文件路径

        Dim newWorkbook As Workbook '定义变量newWorkbook为工作簿类型，用于新建工作簿
        Set newWorkbook = Workbooks.Add '新建工作簿

        Dim j As Long '定义变量j为长整型，用于遍历表2中的所有行，查找与当前姓名相同的行
        For j = 2 To lastRow '从表2第2行开始遍历
            If ws2.Cells(j, "B").Value = name Then '如果当前行的姓名与当前姓名相同，则复制该行到新建的工作簿
                newWorkbook.Sheets(1).Range("A" & newWorkbook.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1 & ":R" & newWorkbook.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1).Value = ws2.Range("A" & j & ":R" & j).Value
            End If
        Next j

        newWorkbook.SaveAs fileName:=filePath '保存工作簿
        newWorkbook.Close SaveChanges:=False '关闭工作簿
    End If
Next i