Sleeper: Export to text files

[snoopies]

Deal all,

I'm trying to write a macro which can export data to text files, but as I'm still a new learner... any suggestions is welcomed!

I need to export 2 files, both are text files but in different extensions.
1) XXX.PRD
2) XXX.DIC

With attached example, I need to convert the data to different PRD files.
The way to define a new PRD file will depend on col D (Quest),
i.e start a new PRD file if the value changes.

PRD filename = value of H1 &_&value of col D

In each PRD file, the structure will look like:
1) Col E's Yellow & Green values (They are headers, where col C (Type) is
empty.

2) if type C is non-blank, I need to copy...
" value of col E "; value of col B
if value of col B is empty, it becomes...
" value of col E "; value of col H

In the DIC file, it copy all rows with col B non-blank.
The format is:

Value of col B [2 sapces] & value of col C & "\" & vaue of col E & "\" & "Value of col H.

This task is really driving me crazy... My another concern is the running time.. I have to deal with around 30000-50000 rows each time, should I convert the excel file into another format first (such as csv) so that it can run faster?

Any help shall be grateful!

[austenr]

This should help you get started with the code to export toa text file:

Public Sub ExportToTextFile(FName As  String, _ 
    Sep As String, SelectionOnly As Boolean)
Dim WholeLine  As String
Dim FNum As Integer
Dim RowNdx As Long
Dim ColNdx As  Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As  Integer
Dim EndCol As Integer
Dim CellValue As  String
Application.ScreenUpdating = False
On Error GoTo  EndMacro:
FNum = FreeFile
If SelectionOnly = True Then
    With  Selection
        StartRow = .Cells(1).row
        StartCol =  .Cells(1).Column
        EndRow = .Cells(.Cells.Count).row
        EndCol  = .Cells(.Cells.Count).Column
    End With
Else
    With  ActiveSheet.UsedRange
        StartRow = .Cells(1).row
        StartCol =  .Cells(1).Column
        EndRow = .Cells(.Cells.Count).row
        EndCol  = .Cells(.Cells.Count).Column
    End With
End If
Open FName For  Output Access Write As #FNum
For RowNdx = StartRow To EndRow
     WholeLine = ""
    For ColNdx = StartCol To EndCol
        If  Cells(RowNdx, ColNdx).Value = "" Then
            CellValue = Chr(34) &  Chr(34)
        Else
           CellValue = _ 
            Application.WorksheetFunction.Text _ 
            (Cells(RowNdx,  ColNdx).Value, _ 
                Cells(RowNdx,  ColNdx).NumberFormat)
        End If
        WholeLine = WholeLine &  CellValue & Sep
    Next ColNdx
    WholeLine = Left(WholeLine,  Len(WholeLine) - Len(Sep))
    Print #FNum, WholeLine
Next  RowNdx
EndMacro:
On Error GoTo 0
Application.ScreenUpdating =  True
Close #FNum
End Sub

You can find this code and a lot more at this link:

http://www.cpearson.com/excel/ExcelPages.htm

HTH

[Norie]

Does this work?

Sub test()
Dim FF(4)
Dim I As Long
Dim LastRow As Long
Dim rng As Range
Dim strToWrite As String
	FF(0) = FreeFile
	Open "C:\" & Range("H1") & ".DIC" For Output As FF(0)
	FF(1) = FreeFile
	Open "C:\" & Range("H1") & "1B.PRD" For Output As FF(1)
	FF(2) = FreeFile
	Open "C:\" & Range("H1") & "1F.PRD" For Output As FF(2)
	FF(3) = FreeFile
	Open "C:\" & Range("H1") & "1G.PRD" For Output As FF(3)
	FF(4) = FreeFile
	Open "C:\" & Range("H1") & "1M.PRD" For Output As FF(4)
	
	LastRow = Range("A65536").End(xlUp).Row
	
	For I = 2 To LastRow
		Set rng = Range("C" & I)
		If rng.Value <> "" Then
			If rng.Offset(0, -1) <> "" Then
				strToWrite = Chr(34) & rng.Offset(0, 2) & Chr(34) & ";" & rng.Offset(0, -1)
			Else
				strToWrite = Chr(34) & rng.Offset(0, 2) & Chr(34) & ";" & rng.Offset(0, 5)
			End If
			
			Select Case rng.Offset(0, 1)
				Case "1B"
					Print #FF(1), strToWrite
				Case "1F"
					Print #FF(2), strToWrite
				Case "1G"
					Print #FF(3), strToWrite
				Case "1M"
					Print #FF(4), strToWrite
			End Select
		End If
		
		If rng.Offset(0, -1) <> "" Then
			strToWrite = rng.Offset(0, -1) & "  " & rng & " \" & rng.Offset(0, 2) & "\" & rng.Offset(0, 5)
			Print #FF(0), strToWrite
		End If
	 Next I
	 
	 For I = 0 To 4
		Close #FF(I)
	 Next I
	 
End Sub

[snoopies]

Hi Norie,

It works! Really for your work!

But one problem is... there may be over 100 headers in real case,
it's not easy to write something like :

FF(0) = FreeFile 
Open "C:\" & Range("H1") & ".DIC" For Output As FF(0)

for over 100 times....

[Norie]

snoopies

What do you mean by headers? Do you mean 1B, 1H etc?

[snoopies]

yup..... what a pity...

[Norie]

Actually I thought this might be the case and might try to work something out.

I think what needs to be done is run an advanced filter on the 'header' column, then dynamically open and name the files.

I'll take a look and hopefully post back.

Option Explicit
Sub test()
Dim arrHeaders
Dim FF()
Dim I As Long
Dim J As Long
Dim LastRow As Long
Dim rng As Range
Dim strToWrite As String

	Range("D1:D1411").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("J1"), Unique:=True
	
	LastRow = Range("J65536").End(xlUp).Row
	
	arrHeaders = Range("J2:J" & LastRow)
	
	Range("J:J").ClearContents
	
	ReDim FF(LastRow - 1)
	
	FF(0) = FreeFile
	Open "C:\" & Range("H1") & ".DIC" For Output As FF(0)
	
	For I = 1 To UBound(FF)
	
		FF(I) = FreeFile
		Open "C:\" & Range("H1") & arrHeaders(I, 1) & ".PRD" For Output As FF(I)
	Next I
	
	LastRow = Range("A65536").End(xlUp).Row
	
	For I = 2 To LastRow
		Set rng = Range("C" & I)
		If rng.Value <> "" Then
			If rng.Offset(0, -1) <> "" Then
				strToWrite = Chr(34) & rng.Offset(0, 2) & Chr(34) & ";" & rng.Offset(0, -1)
			Else
				strToWrite = Chr(34) & rng.Offset(0, 2) & Chr(34) & ";" & rng.Offset(0, 5)
			End If
			
			For J = 1 To UBound(FF)
				If rng.Offset(0, 1) = arrHeaders(J, 1) Then
					Print #FF(J), strToWrite
					Exit For
				End If
			
			Next J
			
		End If
		
		If rng.Offset(0, -1) <> "" Then
			strToWrite = rng.Offset(0, -1) & "  " & rng & " \" & rng.Offset(0, 2) & "\" & rng.Offset(0, 5)
			Print #FF(0), strToWrite
		End If
	 Next I
	 
	 For I = 0 To 4
		Close #FF(I)
	 Next I
	 
End Sub

[snoopies]

Hello Norie, Thanks for your Great Work! I'm so impressed coz' I've worked on it for a long time but it's still not working..

Yes.. your codes work fine!

Just 2 more questions...1) how can I copy those yellow& green headers to PRD files as well (i.e place at top) /esp for those yellow one, there is no fixed format....

Printed Media: Magazine Readership <----**Yellow
*Weekly Magazine Read<------**Green
"Previous 1 Month"; M1F0FWO
"Previous 1 Week"; M1F0FWP
*Weekly Magazines Read Within The Previous 1 Month<----**Green
"News Maker"; M1F0FWQ
"Newsweek (English)"; M1F0FWR

2) How can I rewrite/kill the existing files first before opening any files..?

Many thanks!

Regards,

[Norie]

Sorry I don't understand your first question.

As to your 2nd question you can use the Kill statement.

[snoopies]

I've edited my question (pls see above), Hope it is clear...

You remind me to use kill statement, and luckily I can solve Problem 2 now..
But question 1 is still a problem ..

[Norie]

Sorry but I don't understand the logic behind the headers.

[snoopies]

I understand.... coz' i'm thinking on it,too...
Would it be difficult if changing the way by copying rows from E2 to the end, open & close the PRD files by col D? (open a new one if value of col D changes).. This may skip the logic problem..? I'm not sure...

Sorry but I don't understand the logic behind the headers.

[Norie]

Are the headers indicated by the Type field being blank?

[snoopies]

Yes, you are right.

[snoopies]

I try to modify the codes a bit...but it seems skipping the part "If rng.Value <> "" Then"... anyone can help ?

For i = 2 To LastRow
Set rng = Range("C" & i)
If rng.Value <> "" Then
If rng.Offset(0, -1) <> "" Then
   strToWrite = Chr(34) & rng.Offset(0, 2) & Chr(34) & ";" & rng.Offset(0, -1)
Else
   strToWrite = Chr(34) & rng.Offset(0, 2) & Chr(34) & ";" & rng.Offset(0, 5)
End If
ElseIf rng.Value = "" Then
strToWrite = rng.Offset(0, 2)
For J = 1 To UBound(FF)
If rng.Offset(0, 1) = arrHeaders(J, 1) Then
Print #FF(J), strToWrite
Exit For
End If
Next J
End If

[austenr]

Then rng is never not equal = spaces

[snoopies]

why... sorry,I don't understand...
any solution?

[Norie]

What have you modified?

What where you trying to do with your modification?

[snoopies]

Remember I said I can't solve problem 1?
I need to copy all hearders (rows with col C (Type) blank ) into PRD files...

I added ...

ElseIf rng.Value = "" Then

strToWrite = rng.Offset(0, 2)

The result is unsatisfactory...

What have you modified?

What where you trying to do with your modification?

[sheeeng]

Dim sPath As String
    Dim fName, fPath, strPath As String
    Dim fs As Object, a As Object
    Dim stat1 As String
stat1 = stat1 & "Hello World In Text File" 'Copy all your text here
    sPath = ThisWorkbook.Path & Application.PathSeparator & "OUT FOLDER"
fName = "Output" & ".txt" 'Output file name
Set fs = CreateObject("Scripting.FileSystemObject")
    Set a = fs.CreateTextFile(sPath & Application.PathSeparator & _
    fName, True)
    a.WriteLine (stat1)
    a.Close

Just a additional note.
The code above might be helpfu; to you when you need to output text to a file.

HTH