I have a large file with rows of account data. Each account has a unique number of rows. I want to create a new file for each account, move those account records to the new file and save that new file. The account number is in Column A. I have the logic to loop through the code and determine when the account number changes. My problem is I can't write any records to my newly created file. I get a run-time error'9': Subscript out of range.
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
My code will create the file as the first account name, however when I try to write to that newly created file, I get the subscript out of range error message. My first time through, I'm trying to write the column headers, after that I'm trying to write the row I'm processing.
I've had a go at re-writing your code, creating objects to refer to a 'source sheet' and a 'destination sheet' to help make the code more readable. I've kept as much of your process in there as possible so you should recognise most of it.
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
I've tested the above on a simple table, based on what I think you're trying to do - but as we can't see your data it's difficult to know if this will work.