Question

我将每一行分成自己的工作簿（基于名称）。如果工作簿已经存在，则将其添加到下一个可用行。我知道代码不是最漂亮的，但是可以用！我运行了几次，没有错误。经过测试，我尝试了超过1000行的数据集。由于某种原因，它大约有3％的时间出错。我似乎无法弄清楚是什么原因造成的。（i，1）中的每个单元格均已填写且没有特殊字符。


For i = 4 To Cells(Rows.Count, 1).End(xlUp).Row
    n = Cells(i, 1).Value
    strFileName1 = strPath1 & n & ".xlsx"
    Rows(i).EntireRow.Copy

    If Dir(strFileName1) = "" Then
        Workbooks.Add
        ActiveWorkbook.Sheets("Sheet1").Range("A1").Select
        ActiveWorkbook.Sheets("Sheet1").Paste
        ActiveWorkbook.SaveAs Filename:=strFileName1
        ActiveWorkbook.Close SaveChanges:=False
    Else
        Workbooks.Open (strFileName1)
        Range("A" & Rows.Count).End(xlUp).Offset(1).Select
        ActiveWorkbook.Sheets("Sheet1").Paste
        ActiveWorkbook.SaveAs Filename:=strFileName1
        ActiveWorkbook.Close SaveChanges:=False
    End If

Next

Answer 1

如果您更清楚地了解范围和表格，可能会有所改善：

Dim wb As Workbook, rngDest
Dim shtSrc As Worksheet, i As Long

Set shtSrc = ActiveSheet

For i = 4 To shtSrc.Cells(shtSrc.Rows.Count, 1).End(xlUp).Row

    n = shtSrc.Cells(i, 1).Value
    strFileName1 = strPath1 & n & ".xlsx"

    If Dir(strFileName1) = "" Then
        Set wb = Workbooks.Add()
        wb.SaveAs Filename:=strFileName1
        Set rngDest = wb.Sheets("Sheet1").Range("A1")
    Else
        Set wb = Workbooks.Open(strFileName1)
        Set rngDest = wb.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    End If

    shtSrc.Rows(i).EntireRow.Copy rngDest
    wb.Close savechanges:=True

Next

另请参阅：How to avoid using Select in Excel VBA

for循环中的随机错误

1 个答案: