Question

我正在努力使用一段VBA代码。这个想法非常简单：我想循环遍历10000行的工作簿，复制每一行并粘贴到一个新工作簿中，然后保存该新工作簿。这是针对人力资源部门的。我们正在尝试为每位员工复制并粘贴一行，并将该信息发送给该人。这就是我所拥有的：

Dim i As Long
Dim NewBook As Workbook
Dim EmployeeNumber As String
i = 1
ThisWorkbook.Sheets(1).Range("C1").Activate
EmployeeNumber = Range("C1").Value
Do While EmployeeNumber <> ""
    ThisWorkbook.Activate
    Set NewBook = Workbooks.Add
    ThisWorkbook.Worksheets("Sheet1").Rows(i).Copy NewBook.Worksheets("Sheet1").Range("A1")
   NewBook.SaveAs "path& EmployeeNumber.xlsx"
   ActiveWorkbook.Close
   EmployeeNumber = ThisWorkbook.Sheets(1).Range("C1").Offset(i, 0).Value
   i=i+1
 Set NewBook = Nothing
 Loop

这适用于前500-700行，然后它会中断（我每次测试它几次，代码在不同的行中断开）。错误消息是＆＃34;运行时错误1004，SaveAs方法失败＆＃34;

我非常怀疑这是因为我处理的数据量很大。每次复制并保存行时，都会创建一个新的VBAProject。

See Picture

之前有没有人有同样的问题？非常感谢任何帮助/输入。谢谢！

Answer 1

也许创建一个模板工作簿，然后使用SaveCopyAs保存每个员工的信息：

Sub Tester()

    Dim NewBook As Workbook
    Dim rngEmployeeNum As Range

    Set NewBook = Workbooks.Add(xlWBATWorksheet)

    Set rngEmployeeNum = ThisWorkbook.Sheets(1).Range("C1")

    Do While rngEmployeeNum.Value <> ""

       rngEmployeeNum.EntireRow.Copy NewBook.Sheets(1).Range("A1")

       NewBook.SaveCopyAs ThisWorkbook.Path & "\employees\Emp_" & _
                          Format(rngEmployeeNum.Row, "0000") & ".xlsx"

       Set rngEmployeeNum = rngEmployeeNum.Offset(1, 0)
    Loop

    NewBook.Close False

End Sub

Answer 2

我放弃了我已经运行半小时没有问题。

基本上，我们的代码没有区别。如果这不起作用，请尝试取消注释DoEvents。这让我的Excel时间更好地清理。

Sub TestMakeFiles()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim Start: Start = Timer
    Const ROOT_FOLDER = "C:\Users\Owner\Documents\stack-overflow\test\"
    Dim r As Range
    Dim NewBook As Workbook
    Dim EmployeeNumber As String

    With ThisWorkbook.Sheets(1)
        For Each r In Intersect(.Columns("C"), .UsedRange)
            With Workbooks.Add
                r.EntireRow.Copy Range("A1")
                .SaveAs ROOT_FOLDER & r.Value & ".xlsx"
                .Close
            End With
            'DoEvents
        Next
    End With
    Debug.Print Timer - Start
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

或者，您可以使用这些修改多次运行代码;直到创建所有文件

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
    Dim i As Long
    Dim NewBook As Workbook
    Dim EmployeeNumber As String
    i = 1
    ThisWorkbook.Sheets(1).Range("C1").Activate
    EmployeeNumber = Range("C1").Value
    Do While EmployeeNumber <> ""
        If Dir(Len(Path & EmployeeNumber & ".xlsx")) = 0 Then
            Set NewBook = Workbooks.Add
            ThisWorkbook.Worksheets("Sheet1").Rows(i).Copy NewBook.Worksheets("Sheet1").Range("A1")
            NewBook.SaveAs Path & EmployeeNumber & ".xlsx"
            ActiveWorkbook.Close
            EmployeeNumber = ThisWorkbook.Sheets(1).Range("C1").Offset(i, 0).Value
            i = i + 1
        End If
    Loop

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

VBA运行时错误1004（可能）由内存溢出引起

2 个答案: