VBA入门者求助：将指定行批量拆分至新工作簿（仅粘贴值格式）

嘿，作为VBA入门者，你的需求很清晰，我来帮你修改代码，解决循环、粘贴值格式和文件名的问题。先看修改后的完整代码，再给你拆解关键部分：

Sub CommandButton1_Click()
    Dim MyBook As Workbook, newBook As Workbook
    Dim FileNm As String
    Dim LastRow As Long, i As Long
    
    ' 定义原工作簿
    Set MyBook = ThisWorkbook
    
    ' 获取Sheet1最后一行有数据的行号
    LastRow = MyBook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    
    ' 循环处理第6行到最后一行
    For i = 6 To LastRow
        ' 创建新工作簿
        Set newBook = Workbooks.Add
        
        With newBook.Sheets("Sheet1")
            ' 复制原表1-5行，粘贴值和格式到新表第1行
            MyBook.Sheets("Sheet1").Rows("1:5").Copy
            .Rows("1").PasteSpecial Paste:=xlPasteValuesAndFormats
            
            ' 复制当前循环的第i行，粘贴到新表第6行
            MyBook.Sheets("Sheet1").Rows(i).Copy
            .Rows("6").PasteSpecial Paste:=xlPasteValuesAndFormats
            
            ' 清除剪贴板内容，避免弹窗提示
            Application.CutCopyMode = False
        End With
        
        ' 设置带行号的文件名，保存到原目录
        FileNm = MyBook.Path & "\" & "TEST-BOOK-" & i & ".xlsx"
        newBook.SaveAs Filename:=FileNm, CreateBackup:=False
        
        ' 关闭新工作簿
        newBook.Close Savechanges:=False
    Next i
    
    MsgBox "所有文件已生成完成！", vbInformation
End Sub

关键修改点说明 #

• 循环逻辑实现：

  • 先用LastRow获取原表最后一行的行号，确保循环覆盖所有有数据的行
  • 用For i = 6 To LastRow遍历从第6行开始的每一行，每次循环生成一个独立的新工作簿

• 仅粘贴值与格式：

  • 替换直接粘贴为PasteSpecial Paste:=xlPasteValuesAndFormats，这个参数会只复制单元格的值和格式，完全忽略原单元格的公式
  • 加上Application.CutCopyMode = False清除剪贴板，避免后续操作弹出不必要的提示框

• 动态文件名：

  • 在文件名里加入循环变量i，生成如TEST-BOOK-6.xlsx、TEST-BOOK-7.xlsx这样的唯一文件名，避免文件被覆盖

• 完善流程：

  • 每次循环都重新创建新工作簿，处理完内容后立即保存关闭，确保每个文件严格对应「前5行+单独一行」的内容

注意事项 #

• 确保原工作表的名称是Sheet1，如果你的表名不同，记得修改代码里的MyBook.Sheets("Sheet1")为实际表名
• 如果原目录是只读权限，保存会失败，确保你对原文件所在目录有写入权限
• 运行前建议先备份原文件，避免意外操作导致数据丢失

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