How to use this subroutine on multiple cells?

[Big Ian]

Hi,

I have the following routine that makes text in cell A1 into the contents of
a file defined by B1 and C1.

-------------------------------------------------------
Sub WriteCellToFile()
Dim fso As Object
Dim ts As Object
Dim strCellContents As String
Dim strFileName As String
Dim strPath As String

strCellContents = Range("A1").Text
strFileName = Range("B1").Text
strPath = Range("C1").Text

Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.CreateTextFile(strPath & strFileName, True)
ts.writeline (strCellContents)
ts.Close

End Sub
-------------------------------------------------------

I tried running it with Run-Sub/User Form but I can only get it to work on
one line, if I change the range to A1:A10 I get an error. Can anybody tell me
how to make it into a macro that writes all cells in column A to files?


Thanks,
Ian

 

[Bob Phillips]

Sub WriteCellToFile()
Dim fso As Object
Dim ts As Object
Dim strCellContents As String
Dim strFileName As String
Dim strPath As String
Dim cell As Range

Set fso = CreateObject("Scripting.FileSystemObject")

For Each cell In Range("A1:A10")
strCellContents = cell.Text
strFileName = cell.Text
strPath = cell.Text
Set ts = fso.CreateTextFile(strPath & strFileName, True)
ts.writeline (strCellContents)
ts.Close
Next cell

Set ts = Nothing
Set fso = Nothing

End Sub

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

 

[Big Ian]

Hi Bob,

Thanks for your help. I tried to run the routine but I got an error on line:

Set ts = fso.CreateTextFile(strPath & strFileName, True)

Run-time error '76'
Path not found

Also, I need each line to create a different file. The files are defined in
columns B and C, B is the name and C is the path.

Ian

 

[Bob Phillips]

Sorry, forgot my offsets. Try this

Sub WriteCellToFile()
Dim fso As Object
Dim ts As Object
Dim strCellContents As String
Dim strFileName As String
Dim strPath As String
Dim cell As Range

Set fso = CreateObject("Scripting.FileSystemObject")

For Each cell In Range("A1:A10")
strCellContents = cell.Text
strFileName = cell.Offset(0, 1).Text
strPath = cell.Offset(0, 2).Text
Set ts = fso.CreateTextFile(strPath & strFileName, True)
ts.writeline (strCellContents)
ts.Close
Next cell

Set ts = Nothing
Set fso = Nothing

End Sub



--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

 

[Big Ian]

Bob you're a legend! Many thanks again.

Ian

Sorry, forgot my offsets. Try this

Sub WriteCellToFile()
Dim fso As Object
Dim ts As Object
Dim strCellContents As String
Dim strFileName As String
Dim strPath As String
Dim cell As Range

Set fso = CreateObject("Scripting.FileSystemObject")

For Each cell In Range("A1:A10")
strCellContents = cell.Text
strFileName = cell.Offset(0, 1).Text
strPath = cell.Offset(0, 2).Text
Set ts = fso.CreateTextFile(strPath & strFileName, True)
ts.writeline (strCellContents)
ts.Close
Next cell

Set ts = Nothing
Set fso = Nothing

End Sub



--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)