Problema excel a txt

Mi Macros transforma datos del Excel a txt separando las columnas por un palote, mi problema es que transfiere también la información de filas vacías agregando los palotes hasta el infinito.

Sub CreaTxT()

Dim NombreArchivo, RutaArchivo As String

Dim obj As FileSystemObject

Dim tx As Scripting.TextStream

Dim ht As Worksheet

Dim i, j, nfilas, ncolumnas As Integer

NombreArchivo = "LE" & Cells(2, 4).Value & Cells(3, 4) & "0008010000" & Cells(4, 5) & Cells(5, 5) & Cells(6, 5) & "1"

RutaArchivo = ActiveWorkbook.Path & "\" & NombreArchivo & ".txt"

Set obj = New FileSystemObject

Set tx = obj.CreateTextFile(RutaArchivo)

Set ht = Worksheets("REGISTRO FINAL")

nfilas = ht.Range("a6", ht.Range("a6").End(xlDown)).Cells.Count

ncolumnas = ht.Range("a5", ht.Range("a5").End(xlToRight)).Cells.Count

For i = 5 To nfilas

For j = 1 To ncolumnas

tx.Write ht.Cells(i + 1, j)

If j < ncolumnas Then tx.Write "|"

Next j

tx.WriteLine

Next i

tx.Close