EXCEL Попытка скопировать строку в новую созданную книгу, вытащив индекс из диапазона

Question

У меня большой файл со строками учетных данных. Каждая учетная запись имеет уникальное количество строк. Я хочу создать новый файл для каждой учетной записи, переместить эти записи учетной записи в новый файл и сохранить этот новый файл. Номер счета указан в столбце А. У меня есть логика циклически проходить по коду и определять, когда номер счета изменяется. Моя проблема в том, что я не могу записать какие-либо записи в недавно созданный файл. Я получаю ошибку во время выполнения'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

Я попытался переписать ваш код, создать объекты для ссылки на «исходный лист» и «целевой лист», чтобы сделать код более читабельным.Я сохранил как можно большую часть вашего процесса, поэтому вы должны признать большую его часть.

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

Я проверил вышеизложенное на простой таблице, основываясь на том, что вы пытаетесьсделать - но так как мы не можем видеть ваши данные, трудно понять, сработает ли это.

Answer 2

Попробуйте написать:

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

Обратите внимание, что я записал номер строки между знаками quatatiton: .Rows ("1")