VBA需求：将符合条件的指定行分别保存至独立新工作簿

嗨，你的代码方向是对的，但有几个细节问题影响了效果，我帮你调整优化一下，刚好能实现你要的「每条符合条件的记录生成一个独立工作簿」的需求：

先说说现有代码里的几个小问题：

• 你用For Each Item In Items遍历MyRange，如果这个命名区域是多列的，会逐个单元格循环，而不是按行——这会导致同一行可能被重复处理（比如该行其他列也有大于0的值）
• 用Now生成文件名的时候，循环跑太快的话，多个文件会有完全一样的时间戳，要么覆盖之前的文件，要么直接报错
• 依赖Selection粘贴不够稳定，VBA里最好直接用对象引用来操作，不容易出问题

下面是修改后的完整代码，我标了关键的改进点：

Sub DPD()
    Dim wsSource As Worksheet
    Dim rngMyRange As Range
    Dim rngRow As Range
    Dim wbNew As Workbook
    Dim strSavePath As String
    Dim intFileCounter As Integer ' 用来生成唯一文件名的计数器
    
    ' 初始化基础变量
    Set wsSource = ThisWorkbook.Worksheets("Out")
    Set rngMyRange = wsSource.Range("MyRange")
    strSavePath = "C:\DPD\"
    intFileCounter = 1
    
    ' 先检查保存目录是否存在，不存在就创建
    If Dir(strSavePath, vbDirectory) = "" Then
        MkDir strSavePath
    End If
    
    ' 关闭屏幕更新和警告，让代码跑更快更安静
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' 按行遍历命名区域，确保每次处理的是一整行
    For Each rngRow In rngMyRange.Rows
        ' 检查当前行的C列值是否大于0
        ' 如果MyRange不是从A列开始的，把这里的3改成C列在MyRange里的相对列号
        If rngRow.Cells(1, 3).Value > 0 Then
            ' 创建新工作簿
            Set wbNew = Workbooks.Add
            ' 把当前行的值复制到新工作簿的首行
            rngRow.Copy
            wbNew.Worksheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
            Application.CutCopyMode = False
            
            ' 保存为CSV，用时间戳+计数器确保文件名绝对唯一
            wbNew.SaveAs Filename:=strSavePath & "pf_" & Format(Now, "yyyy_mm_dd_hh_mm_ss") & "_" & intFileCounter & ".csv", _
                FileFormat:=xlCSV
            wbNew.Close SaveChanges:=False
            intFileCounter = intFileCounter + 1
        End If
    Next rngRow
    
    ' 恢复系统设置，弹出完成提示
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "搞定啦！一共生成了" & intFileCounter - 1 & "个独立文件～", vbInformation
End Sub

几个重要的优化点说明： #

• 按行遍历：改用rngMyRange.Rows循环，确保每次处理的是一整行，不会重复处理同一记录
• 唯一文件名：把时间戳精确到秒，再加上递增的计数器，彻底避免文件名重复的问题
• 稳定操作：直接引用新工作簿的工作表进行粘贴，再也不用依赖Selection，代码更可靠
• 自动创建目录：如果C:\DPD文件夹不存在，代码会自动创建，不用手动提前建
• 性能提升：关闭屏幕更新，减少闪烁，运行速度更快

另外给你提个小提醒：
如果你的命名区域MyRange只包含C列（不是整行区域），那把判断条件改成If rngRow.Value > 0 Then就可以了；要是C列不在MyRange里，就换成wsSource.Cells(rngRow.Row, "C").Value > 0，这样就能准确拿到C列的值啦。

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