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!

:help

[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 :friends:

[Ken Puls]

Hi there,

For whatever reason, this will not work:

rng.Value

When you step through the procedure, you can check this by opening up the Locals window right after you assign rng it's range. If you expand the tree, you won't find the Value property in there anywhere. Since it can't be found, it can't ever be evaluated, and therefore you'll always get the same result.

What is there, however, is the Value2 property. If I've read everything right, I think that's what you're wanting to test.

I haven't tested any of the rest of the code, but if it all works as intended, and the value test is the only issue, this should work it out:

For i = 2 To LastRow
Set rng = Range("C" & i)
If rng.Value2 <> "" 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.Value2 = "" 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

HTH,

[snoopies]

Hi Kpuls,

Unfortunately, the result is same ... it skips the upper part..
:dunno .........

[Ken Puls]

Hi there,

Just got to work today. If no one else gets there, I'll try and take a look tonight to see if I can work out what's going on.

[snoopies]

Hi Kplus, I've checked the email and understand that you are busy in other jobs right now. Thanks in anyway.

Anyone can help? :)