请教各位大神，这个拆分出来的文件为啥只有一条记录？

光伟

各位大神：

      菜鸟来求助了，有个文件需要进行拆分，例如附件里的信息同一个合同编号同一个供应商的多条记录拆成一个文件，目前和同事一起研究了一套代码出来，但拆分出来的文件只有一条记录！
      请问这代码是哪里出错了，先跪谢了！
文件里第一个表是信息清单，第二个表是代码
需要拆分的文件.rar (12.41 KB, 下载次数: 0)

前天 19:23 上传

点击文件名下载附件

尹子杀手

Sub 按供应商_合同编号_拆分_多条记录()
    Dim ws As Worksheet
    Dim newWb As Workbook
    Dim lastRow As Long
    Dim i As Long
    Dim savePath As String
    Dim dict As Object
    Dim key As Variant
    Dim 合同编号 As String, 供应商名称 As String
   
    ' 关闭弹窗
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    ' 你的表
    Set ws = ActiveSheet
    savePath = ThisWorkbook.Path & "\"
   
    ' 字典：按 合同编号|供应商 分组
    Set dict = CreateObject("Scripting.Dictionary")
   
    ' 自动找最后一行（G列合同编号）
    lastRow = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row

    ' 第一步：收集所有唯一组合
    For i = 4 To lastRow
        合同编号 = Trim(ws.Cells(i, "G").Value)
        供应商名称 = Trim(ws.Cells(i, "L").Value)
        
        If 合同编号  "" And 供应商名称  "" Then
            dict(合同编号 & "|" & 供应商名称) = 供应商名称
        End If
    Next i

    ' 第二步：生成文件
    For Each key In dict.Keys
        合同编号 = Split(key, "|")(0)
        供应商名称 = dict(key)
        
        ' 新文件
        Set newWb = Workbooks.Add(xlWBATWorksheet)
        
        ' 复制表头（1–3行）
        ws.Rows("1:3").Copy newWb.Sheets(1).Range("A1")
        
        ' ↓↓↓ 关键修复：循环复制所有匹配行 ↓↓↓
        For i = 4 To lastRow
            If Trim(ws.Cells(i, "G").Value) = 合同编号 _
               And Trim(ws.Cells(i, "L").Value) = 供应商名称 Then
               
                ' 粘贴到下一行
                ws.Rows(i).Copy _
                newWb.Sheets(1).Cells(newWb.Sheets(1).Rows.Count, "A").End(xlUp).Offset(1, 0)
            End If
        Next i
        
        ' 列宽自适应
        newWb.Sheets(1).UsedRange.Columns.AutoFit
        
        ' 保存：只留供应商名称
        newWb.SaveAs savePath & 供应商名称 & ".xlsx", xlOpenXMLWorkbook
        newWb.Close SaveChanges:=False
    Next key

    ' 恢复
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
   
    MsgBox "拆分完成！每个文件都包含【全部多条记录】！" & vbCrLf & "保存到：" & savePath

End Sub

夏日清荷

你没有一次一次去判断行的位置

华夏战神