Copy and Save range to .txt file with file name from cell

[sivakr68]

Hi

[pre]

A	                B	                C	          D
1  Group1_20_08_2013	Group2_20_08_2013     Group4_20_08_2013    Group4_20_08_2013
2	56	               67	                45	          34
3	46	               23	                45	          45
4	45	               56	               767	          87
5	56	               45	                54	          45
6	45	               45	                45	          45
7	454	             3423	              2234	         232
8	54	              435	               345	         345
I need to create a macro that will save 

cell A2:A8 to a *.txt file with the file name as "Group1_20_08_2013.txt" (as in A1)
cell B2:B8 to a *.txt file with the file name as "Group2_20_08_2013.txt" (as in B1)
cell C2:C8 to a *.txt file with the file name as "Group3_20_08_2013.txt" (as in c1)

[/pre]
Thanks


edited with backticks

 

[shrivallabha]

Here's one way:

[pre]

Option Explicit
Public Sub SaveText()
Dim oFSO As Object
Dim oTXT As Object
Dim r As Range
Dim i As Integer

'Set range reference here and it assumes that the previous row holds header info
Set r = Range("A2:D8") 'A1:D1 holds header info
' Used for writing to textfiles
Set oFSO = CreateObject("Scripting.FileSystemObject")

For i = 1 To r.Columns.Count
'Will save in the same directory as workbook is!
Set oTXT = oFSO.opentextfile(ThisWorkbook.Path & "" & r.Cells(1, i).Offset(-1, 0).Value & ".txt", 2, True)
' Write data into text file
oTXT.write Join(Application.Transpose(r.Columns(i).Value), vbCrLf)
' Close file
oTXT.Close
Next i

'Release variables
Set oFSO = Nothing
Set oTXT = Nothing

End Sub

[/pre]

 

[sivakr68]

Hi Shrivallabha


I ran the above and got a

Run-time error'52

Bad file name or number


Regards


Siva

 

[Luke M]

Modifying shrivallabha's code to give some debugging info...try running this and telling us what it does.

[pre]

Option Explicit
Public Sub SaveText()
Dim oFSO As Object
Dim oTXT As Object
Dim r As Range
Dim i As Integer

Dim debugName As String

'Set range reference here and it assumes that the previous row holds header info
Set r = Range("A2:D8") 'A1:D1 holds header info
' Used for writing to textfiles
Set oFSO = CreateObject("Scripting.FileSystemObject")

On Error GoTo badName
For i = 1 To r.Columns.Count
'Will save in the same directory as workbook is!
debugName = ThisWorkbook.Path & "" & r.Cells(1, i).Offset(-1, 0).Value & ".txt"
Set oTXT = oFSO.opentextfile(debugName, 2, True)
' Write data into text file
oTXT.write Join(Application.Transpose(r.Columns(i).Value), vbCrLf)
' Close file
oTXT.Close
Next i
On Error GoTo 0

'Release variables
Set oFSO = Nothing
Set oTXT = Nothing
Exit Sub

badName:
MsgBox debugName & " caused problems"
Set oFSO = Nothing
Set oTXT = Nothing

End Sub

[/pre]

 

[sivakr68]

It works !!!


Thanks Luke & Shrivallabha

 

[shrivallabha]

Very good. Bad file name or number would mean, following line is not working:

Set oTXT = oFSO.opentextfile(ThisWorkbook.Path & "" & r.Cells(1, i).Offset(-1, 0).Value & ".txt", 2, True)

I'd like to know what was causing it?

 

[Luke M]

Hmm. Like shrivallabha, I'm curious as to how it got fixed. I didn't really change anything, just added an error reporting feature. But, glad that it's working now...

 

[Marc L]

Hi sivakr68, a simplest way without using FSO :

[pre]

Sub ExportColumns()
For C& = 1 To [A1].CurrentRegion.Columns.Count
If Cells(1, C).Text > "" Then
R& = Cells(Rows.Count, C).End(xlUp).Row

If R > 1 Then
F% = FreeFile
Open ThisWorkbook.Path & "" & Cells(1, C).Text & " .txt" For Output As #F
Print #F, Join(Application.Transpose(Cells(2, C).Resize(R - 1)), vbNewLine)
Close #F
End If
End If
Next
End Sub

 

If each column has always the same number of rows :

Sub ExportColumns()
R& = [A1].CurrentRegion.Rows.Count

If R > 1 Then
For C& = 1 To [A1].CurrentRegion.Columns.Count
If Cells(1, C).Text > "" Then
F% = FreeFile
Open ThisWorkbook.Path & "" & Cells(1, C).Text & " .txt" For Output As #F
Print #F, Join(Application.Transpose(Cells(2, C).Resize(R - 1)), vbNewLine)
Close #F
End If
Next
End If
End Sub

[/pre]