Question

我有一个很大的文件，其中包含帐户数据行。每个帐户都有唯一的行数。我想为每个帐户创建一个新文件，将这些帐户记录移至新文件并保存该新文件。帐号在A列中。我有逻辑遍历代码并确定帐号何时更改。我的问题是我无法将任何记录写入新创建的文件。我收到运行时错误“ 9”：下标超出范围。

Private Sub createfiles()

Lastrow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

Dim fileName As String
Dim initial As Integer

initial = 1

fileName = "O:\Paula\Z Install History\Testing\" & Cells(initial + 1, 1).Text & ".xlsx"

Set Newbook = Workbooks.Add

With Newbook
    .Title = "Installment Trans History"
    .Subject = "legal Request"
    .SaveAs fileName:=fileName
End With

' open new workbook and copy first title row

 Workbooks.Open (fileName)

  Workbooks("25 acct record.xlsm").Worksheets("sheet1").Rows(1).EntireRow.Copy _
        Workbooks(fileName).Worksheets("sheet1").Range("A1").Select
  ' set row value in new file
  writerow = 2
For current = 2 To Lastrow

 If Worksheets("Sheet1").Cells(current, 1) <> Worksheets("Sheet1").Cells(current + 1, 1) Then

      ' Write the current record and close file

      Workbooks("25 acct record.xlsm").Worksheets("sheet1").Rows(current, 1).Copy _
        Workbooks(fileName).Worksheets("sheet1").Cells(writerow, 1)

      Workbooks(fileName).Close SaveChanges:=True

      writerow = 1

      ' create a new file  and write column header row

      fileName = "O:\Paula\Z Install History\Testing\" & Cells(current + 1, 1).Text & ".xlsx"
         Set Newbook = Workbooks.Add
            With Newbook
                 .Title = "Installment Trans History"
                 .Subject = "legal Request"
                 .SaveAs fileName:=fileName

          End With
          Workbooks.Open (fileName)

          Workbooks("25 acct record.xlsm").Worksheets("sheet1").Rows(1).EntireRow.Copy _
                Workbooks(fileName).Worksheets("sheet1").Range(writerow, 1).Select
          writerow = writerow + 1

     Else
      ' Workbooks("25 acct record.xlsm").Worksheets("sheet1").Range("A1").Copy _
        Workbooks(fileName).Worksheets("sheet1").Range("A1")

       Workbooks("25 acct record.xlsm").Worksheets("sheet1").Cells(1, 1).Copy _
                  Workbooks(fileName).Worksheets("sheet1").Cells(writerow, 1)

       writerow = writerow + 1



 End If
Next

ThisWorkbook.Worksheets("Sheet1").Cells(1, 1).Select

End Sub

我的代码将创建该文件作为第一个帐户名，但是当我尝试写入该新创建的文件时，出现下标超出范围的错误消息。第一次，我试图写列标题，然后再写我正在处理的行。

Answer 1

尝试写作：

Workbooks("25 acct record.xlsm").Worksheets("sheet1").Rows("1").EntireRow.Copy _ Workbooks(fileName).Worksheets("sheet1").Range("A1").Select

请注意，我在配额标记之间写了行号：.Rows（“ 1”）

Answer 2

我可以重新编写代码，创建对象来引用“源工作表”和“目标工作表”，以帮助提高代码的可读性。我已尽可能多地保留您的流程，因此您应该了解其中的大部分内容。

Private Sub createfiles_TestMe()

Dim LastRow As Long
Dim writeRow As Long
Dim Current As Long
Dim fileName As String
Dim initial As Integer
Dim DestBook As Workbook
Dim SourceBook As Workbook
Dim DestSheet As Worksheet
Dim SourceSheet As Worksheet

Set SourceBook = Workbooks("25 acct record.xlsm")
Set SourceSheet = SourceBook.Worksheets("sheet1")

LastRow = SourceSheet.Cells(SourceSheet.Rows.Count, 1).End(xlUp).Row

initial = 1

fileName = "O:\Paula\Z Install History\Testing\" & Cells(initial + 1, 1).Text & ".xlsx"

Set DestBook = Workbooks.Add

With DestBook
    .Title = "Installment Trans History"
    .Subject = "legal Request"
    .SaveAs fileName:=fileName
    Set DestSheet = .Worksheets("sheet1")
End With

Set DestSheet = DestBook.Worksheets("sheet1")

' Copy header across

 SourceSheet.Rows(1).Copy DestSheet.Rows(1)

' set row value in new file

writeRow = 2

For Current = 2 To LastRow

    If SourceSheet.Cells(Current, 1) <> SourceSheet.Cells(Current + 1, 1) Then

        ' Write the current record and close file

        SourceSheet.Rows(Current).Copy DestSheet.Rows(writeRow)

        DestBook.Close SaveChanges:=True

        writeRow = 1

        ' create a new file  and write column header row
        If Current < LastRow Then

            fileName = "O:\Paula\Z Install History\Testing\" & Cells(Current + 1, 1).Text & ".xlsx"

            Set DestBook = Workbooks.Add

            With DestBook
                .Title = "Installment Trans History"
                .Subject = "legal Request"
                .SaveAs fileName:=fileName
                Set DestSheet = .Worksheets("sheet1")
            End With

            SourceSheet.Rows(1).Copy DestSheet.Rows(1)
        End If
    Else

        SourceSheet.Rows(Current).Copy DestSheet.Rows(writeRow)

    End If

    writeRow = writeRow + 1
Next

SourceSheet.Cells(1, 1).Select

End Sub

我已经基于我认为您要尝试做的事情在一个简单的表上进行了测试-但由于我们看不到您的数据，因此很难知道这是否行得通。

EXCEL试图将行复制到新创建的工作簿中，从而使下标超出范围

2 个答案: