Macro To Create A .txt File

[excelnube]

Hi,

I'm trying to create a .txt file from the data in my spreadsheet.

Requirements:

1) Copy columns A C D J S
2) Where the value in Column S = Out Of Stock
3) Each column to be separated by **
4) Each row to be separated by *split*
5) Remove *split* from the last record

Example of output file:

A**C**D**J**S*split*
0001**3**01-12-2012**Refund sent**Out of Stock*split*
0002**4**02-12-2012**Sent for fabrication**Out of Stock*split*
0003**4**03-12-2012**All items in red**Out of Stock*split*
0004**1**28-11-2012**Deliver on Mondays only**Out of Stock

My code so far:

Sub Create_OutOfStocktxt_File()
    Dim fs As Object, a As Object, i As Integer, z As String, t As String, l As String, mn As String
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set a = fs.CreateTextFile("C:\\OutOfStock.txt", True)
    Dim r As Long
    Dim c As Long
    Dim Cols
    
    Cols = Split("A C D J S")
    
    For r = 1 To Range("A" & Rows.Count).End(xlUp).Row
        z = ""
    For c = 0 To UBound(Cols)
        z = z & Cells(r, Cols(c)) & "*Split*"
    Next c
        a.writeline z
    Next r
    
End Sub

Any help appreciated.

Thanks

 

[excelnube]

Great, working as expected.

Last request, ** is being added to the start of every row e.g

**00001**05-12-2012**....

Whereas im after:

00001**05-12-2012**...

 

[Andrew Poulsom]

Try:

Sub Create_OutOfStocktxt_File()
    Dim fs As Object
    Dim a As Object
    Dim Cols As Variant
    Dim LR As Long
    Dim r As Long
    Dim z As String
    Dim First As Boolean
    Dim c As Long
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set a = fs.CreateTextFile(CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator & "OutOfStock.txt", True)
    Cols = Split("A C D J S")
    LR = Range("A" & Rows.Count).End(xlUp).Row
    For r = 1 To LR
        First = True
        If IsError(Range("S" & r).Value) Then
            Range("S" & r).ClearContents
        End If
        If Range("S" & r).Value = "Out of Stock" Then
            z = ""
            For c = LBound(Cols) To UBound(Cols)
                If First = True Then
                    z = Cells(r, Cols(c)).Text
                    First = False
                Else
                    z = z & "**" & Cells(r, Cols(c)).Text
                End If
            Next c
            If WorksheetFunction.CountIf(Range("S" & r + 1 & ":S" & LR), "Out of Stock") > 0 Then z = z & "*Split*"
            a.writeline z
        End If
    Next r
End Sub

 

[excelnube]

Thank you very much