problem with save as?

[sophie619]

The following code (full code at the bottom) is a subroutine in which I want to save a worksheet row by row into textfiles. Row 1 has the headers.

It works fine until I get to the execution of this line:

wbNew.SaveAs fileName:=strFile, FileFormat:=xlText, CreateBackup:=False

And the error I get is a run-time error "Automation error", and when I hit DEBUG, it highlights the line of code above it:

wb.ActiveSheet.Rows(r).Copy wbNew.Sheets(1).Rows(1)

As far as I can tell, that line executes correctly, so I'm confused as to why it would highlight that line.
I've used the Saveas code in other subroutines and have been successful.
Can anyone figure out what's wrong?


Full code here:

    Sub SaveRowsAsTXT()
    Dim wb As Excel.Workbook, wbNew As Excel.Workbook
    Dim r As Long
    Dim strFolder As String
    Dim strFile As String
    Dim fName As String
    Dim LastCol As Long
    Dim LastRow As Long
   
    
    strFolder = "L:\test\" 'folder where files will be saved
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False 'will overwrite existing files without asking
        
    ActiveWorkbook.Worksheets("Sheet1").Visible = True 'currently hidden
    ActiveWorkbook.Worksheets("Sheet1").Copy
    
    Set wb = ActiveWorkbook
        
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
        
    Set wbNew = Workbooks.Add 'adds blank workbook
    wb.Activate
        
    For r = 2 To LastRow
        fName = Cells(r, 1).Value
        strFile = strFolder & fName & ".txt"
        'copy row to new wkbk
        wb.ActiveSheet.Rows(r).Copy wbNew.Sheets(1).Rows(1)
        'save
        wbNew.SaveAs fileName:=strFile, FileFormat:=xlText, CreateBackup:=False
        'close
        wbNew.Close
    
    Next
    
    ActiveWorkbook.Worksheets("Sheet1").Visible = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub

 

[sophie619]

Figured out that I had to move

Set wbNew = Workbooks.Add 'adds blank workbook
        wb.Activate

into the For loop,
add

Dim ws As Excel.Worksheet

and replace

wb.ActiveSheet.Rows(r).Copy wbNew.Sheets(1).Rows(1)

with

ws.Rows(r).Copy wbNew.Sheets(1).Rows(1)

 

[Artik]

sophie619, discover yet another way to write rows to the files:

Sub SaveRowsAsTXT_1()
  Dim strFolder As String
  Dim LastRow  As Long
  Dim LastCol  As Integer
  Dim r As Long, c As Integer
  Dim vRow     As Variant
  Dim fName    As String
  Dim strFile  As String
  Dim io       As Integer

  strFolder = "C:\test\"    'folder where files will be saved

  If Dir(strFolder, vbDirectory) = "" Then
    MsgBox "Path " & strFolder & " not find!", vbExclamation
    Exit Sub
  End If

  With ActiveWorkbook.Worksheets("Sheet1")
    LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column

    For r = 2 To LastRow
      fName = .Cells(r, 1).Value
      strFile = strFolder & fName & ".txt"
      
      vRow = Application.Transpose(Application.Transpose(.Range(.Cells(r, 1), .Cells(r, LastCol)).Value))
      vRow = Join(vRow, vbTab)

      io = FreeFile()
      Open strFile For Output As io
      Print #io, vRow
      Close io

    Next r

  End With

End Sub

Artik