VBA按Prod.Type变量值批量复制行到新Excel文件问题求助

先帮你梳理下原代码里的几个关键问题，这些问题直接导致你只得到表头，没有正确复制目标行：

原代码的核心问题 #

• 变量未初始化：prodNum和shnum一开始默认值是0，而你的数据里Prod.Type是从1/2开始的，所以初始判断Range("A" & i).Value = prodNum永远不成立，直接进入Else分支保存空文件。
• 循环结构逻辑混乱：外层的For counter = 1 To 20完全多余，它会重复创建20个工作簿，每个工作簿都只执行一次内层循环，逻辑完全错误。
• 引用不明确：内层循环里用ActiveSheet，但ActiveSheet不一定是你的源工作表consh，容易导致获取行数错误。
• 复制语法错误：consh.Rows("A" & i).Copy是错误写法，要复制整行应该用consh.Rows(i).Copy或者consh.Range("A" & i).EntireRow.Copy。
• 粘贴逻辑错误：每次都粘贴到wbtarget.Sheets(1).Range("A2")，就算找到匹配行也只会覆盖A2，而且保存文件的时机不对，每次不匹配就保存，导致文件只有表头。

修正后的代码 #

下面是重构后的代码，实现按Prod.Type分组导出到独立文件的功能，注释里标注了关键修改点：

Sub ExportByProdType()
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim wbTarget As Workbook
    Dim wsTarget As Worksheet
    Dim lastRow As Long
    Dim prodNum As Long
    Dim currentRow As Long
    Dim targetRow As Long
    Dim savePath As String
    
    ' 初始化变量，明确引用源工作簿和工作表
    Set wbSource = ThisWorkbook
    Set wsSource = wbSource.Sheets("Sheet1")
    savePath = "C:\Users\Anon\Desktop\Project\" ' 保存路径
    prodNum = 1 ' 从第一个Prod.Type开始，可根据实际数据调整
    lastRow = wsSource.Range("A" & wsSource.Rows.Count).End(xlUp).Row ' 获取源数据最后一行
    
    ' 遍历每个Prod.Type
    Do While prodNum <= wsSource.Range("A" & lastRow).Value ' 假设Prod.Type连续递增，不连续可调整逻辑
        ' 创建新工作簿
        Set wbTarget = Workbooks.Add
        Set wsTarget = wbTarget.Sheets(1)
        
        ' 复制表头到目标工作表
        wsSource.Rows(1).Copy wsTarget.Range("A1")
        targetRow = 2 ' 目标工作表从第2行开始粘贴数据
        
        ' 遍历源数据，复制匹配的行
        For currentRow = 2 To lastRow ' 从第2行开始跳过表头
            If wsSource.Range("A" & currentRow).Value = prodNum Then
                ' 复制整行到目标工作表的下一行
                wsSource.Rows(currentRow).Copy wsTarget.Range("A" & targetRow)
                targetRow = targetRow + 1 ' 目标行下移，避免覆盖
            End If
        Next currentRow
        
        ' 保存并关闭目标工作簿
        wbTarget.SaveAs savePath & prodNum & ".xlsx"
        wbTarget.Close SaveChanges:=False ' 已经保存过，无需再保存
        
        ' 切换到下一个Prod.Type
        prodNum = prodNum + 1
    Loop
    
    MsgBox "导出完成！", vbInformation
End Sub

额外说明 #

1. 如果你的Prod.Type不是连续递增的（比如有1、3、5这种间隔），可以先提取所有唯一的Prod.Type值，再逐个遍历，比如用字典来存储唯一值：

' 提取唯一Prod.Type的示例代码
Dim prodDict As Object
Set prodDict = CreateObject("Scripting.Dictionary")
For currentRow = 2 To lastRow
    prodVal = wsSource.Range("A" & currentRow).Value
    If Not prodDict.exists(prodVal) Then
        prodDict.Add prodVal, 0
    End If
Next currentRow
' 然后遍历字典的键
For Each prodNum In prodDict.keys
    ' 执行导出逻辑
Next prodNum

2. 注意保存路径要确保存在，如果路径不存在会报错，可以加上路径检查的代码（比如用Dir函数判断）。
3. 原代码里的shnum其实可以直接用prodNum作为文件名，更直观，避免混淆。

内容的提问来源于stack exchange，提问作者BibiC