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

 

[Andrew Poulsom]

Try:

        If IsError(Range("S" & r).Value) Then
            Range("S" & r).ClearContents
        End If

 

[excelnube]

Try:

        If IsError(Range("S" & r).Value) Then
            Range("S" & r).ClearContents
        End If

Thanks, tried an is falling over at:

        If IsError(Range("S" & r).Value)

Hovering over Range, error produced is: Range("S" & r).Value = <Method 'Range' of Object '_Global' failed>

Current code:

Dim fs As Object
    Dim a As Object
    Dim Cols As Variant
    Dim r As Long
    Dim z As String
    Dim c As Long
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set a = fs.CreateTextFile("C:\\OutOfStock.txt", True)
    Cols = Split("A C D J S")
    
    If IsError(Range("S" & r).Value) Then
            Range("S" & r).ClearContents
    End If
    
    
    For r = 1 To Range("A" & Rows.Count).End(xlUp).Row
        If Range("S" & r).Value = "Out of Stock" Then
            z = ""
            For c = LBound(Cols) To UBound(Cols)
                z = z & "**" & Cells(r, Cols(c)).Text
            Next c
            z = z & "*Split*"
            a.writeline z
        End If
    Next r

 

[Andrew Poulsom]

It needs to be inside your r loop (at the beginning like you had it in Post #10).

 

[excelnube]

It needs to be inside your r loop (at the beginning like you had it in Post #10).

No errors now

However, the *split* on the last record appears to still be present.

 

[Andrew Poulsom]

Sorry, I missed that requirement:

If r < Range("A" & Rows.Count).End(xlUp).Row Then z = z & "*Split*"

 

[excelnube]

Sorry, I missed that requirement:

If r < Range("A" & Rows.Count).End(xlUp).Row Then z = z & "*Split*"

Thanks, tried this however the final record in the .txt file is still displaying *Split*

My code:

Dim fs As Object
    Dim a As Object
    Dim Cols As Variant
    Dim r As Long
    Dim z As String
    Dim c As Long
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set a = fs.CreateTextFile("C:\\OutOfStock.txt", True)
    Cols = Split("A C D J S")
    
    For r = 1 To Range("A" & Rows.Count).End(xlUp).Row
    
        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)
                z = z & "**" & Cells(r, Cols(c)).Text
            Next c
                z = z & "*Split*"
            a.writeline z
        End If
        
        [B]If r < Range("A" & Rows.Count).End(xlUp).Row Then z = z & "*Split*"[/B]
        
    Next r

 

[Andrew Poulsom]

I guess the last row didn't contain "Out of Stock". Try replacing:

If r < Range("A" & Rows.Count).End(xlUp).Row Then z = z & "*Split*"

with:

If WorksheetFunction.CountIf(Range("S" & r + 1 & ":S" & LR), "Out of Stock") > 0 Then z = z & "*Split*"

 

[excelnube]

I guess the last row didn't contain "Out of Stock". Try replacing:

If r < Range("A" & Rows.Count).End(xlUp).Row Then z = z & "*Split*"

with:

If WorksheetFunction.CountIf(Range("S" & r + 1 & ":S" & LR), "Out of Stock") > 0 Then z = z & "*Split*"

Should:

If WorksheetFunction.CountIf(Range("S" & r + 1 & ":S" & LR), "Out of Stock") > 0 Then z = z & "*Split*"

Be LR, or just R ?

 

[excelnube]

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

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

Whereas im after:

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

 

[Andrew Poulsom]

Sorry, I forgot that I made some additional changes:

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 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
        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)
                z = z & "**" & Cells(r, Cols(c)).Text
            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