Excel - Un archivo txt por cada fila de excel con nombre del txt de una celda

Sub Macro1()

'Crea un archivo por cada linea , le pone el nombre de la celda b.txt 

' separador PIPE , longitud variable, 

' Macro1 Macro

' Acceso directo: CTRL+q

    Limite = Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row

    For i = 2 To Limite

        Data = Range("A" & i).Value & "|" & Range("B" & i).Value & "|" & Range("C" & i).Value & "|" & Range("D" & i).Value & "|" & Range("E" & i).Value & "|" & Range("F" & i).Value

        Filename = Application.ActiveWorkbook.Path & "\" & Range("B" & i).Value & ".txt"

        Open Filename For Append As #1

            Print #1, Data

        Close #1

    Next i

End Sub

i = 2

   while  Range("A" & i).Value <> ""

        Data = Range("A" & i).Value & "|" & Range("B" & i).Value & "|" & Range("C" & i).Value & "|" & Range("D" & i).Value & "|" & Range("E" & i).Value & "|" & Range("F" & i).Value

        Filename = Application.ActiveWorkbook.Path & "\" & Range("B" & i).Value & ".txt"

        Open Filename For Append As #1

            Print #1, Data

        Close #1

        i =i  + 1

wend

Sub CrearArchivoTexto()

   'Explora hasta la ultima fila activa en la hoja

    Set fs = CreateObject("Scripting.FileSystemObject")

    For Cont = 2 To ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row

        If Len(Range("B" & Cont).Value) >= 1 Then

           Set a = fs.CreateTextFile("D:\" & Range("B" & Cont).Value & ".txt", True)

           a.Close

        End If

    Next Cont

End Sub

Sub CrearArchivoTexto2()

    'Explora hasta encontrar la primera celda vacia

    Set fs = CreateObject("Scripting.FileSystemObject")

    Cont = 2

    Do While Len(Range("B" & Cont).Value) >= 1

       Set a = fs.CreateTextFile("D:\" & Range("B" & Cont).Value & ".txt", True)

       a.Close

       Cont = Cont + 1

    Loop

End Sub

Sub CrearArchivoTexto()

   'Explora hasta la ultima fila activa en la hoja

    Set fs = CreateObject("Scripting.FileSystemObject")

    For Cont = 2 To ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row

       If Len(Trim(Range("B" & Cont).Value)) >= 1 Then

          Set a = fs.CreateTextFile("D:\" & Range("B" & Cont).Value & ".txt", True)

          a.Close

       End If

    Next Cont

End Sub

Sub CrearArchivoTexto2()

      'Explora hasta encontrar la primera celda vacia

      Set fs = CreateObject("Scripting.FileSystemObject")

      Cont = 2

      Do While Len(Trim(Range("B" & Cont).Value)) >= 1

            Set a = fs.CreateTextFile("D:\" & Range("B" & Cont).Value & ".txt", True)

            a.Close

            Cont = Cont + 1

      Loop

End Sub

Sin referencias(Late Binding):

dim fso as object

set fso= CreateObject("Scripting.FileSystemObject")

Dim fso As FileSystemObject

Set fso= New FileSystemObject

Dim fso as new FileSystemObject

Sub rngDelimitador()

'@dj.vivanco

'ver 1.0.0 24-07-2020

Dim rng As Range, celda As Range, uf As Long, col As Integer

Dim rngFila As Variant, datosFila As Variant

Dim nomArchivo As String, Carpeta As String

uf = Range("A" & Rows.Count).End(xlUp).Row 'ultima fila con datos de la columna A

Set rng = Range("A2:A" & uf)

rng.Interior.Pattern = xlNone ' quito colores a la columna A

For Each celda In rng

    If celda.Value <> vbNullString Then 'si hay datos sigue:

        nomArchivo = celda.Value & "-" & celda.Offset(0, 1) 'concateno para noombre de archivo

        col = Cells(celda.Row, Columns.Count).End(xlToLeft).Column 'ultima columna a contar de la derecha

        If col > 1 Then 'si hay filas vacias daria error sin esta linea de código if

            rngFila = Range(celda, celda.Offset(0, col - 1)) 'establece el rango desde la celda actual hasta la final

            'JOIN une los 2 transpose con el separador "|",

            '(uno crea un array vertical y el otro lo deja horizontal nuevamente

            datosFila = Join(Application.Transpose(Application.Transpose(rngFila)), " | ")

            miCarpeta = "C:\Users\TUUSUARIOAQUI\Desktop\MICARPETAPLANILLAS\" 'RUTA COMPLETA AQUI

            Open miCarpeta & nomArchivo & ".txt" For Append As #1 'abre el archivo txt como numero 1

            Print #1, datosFila 'imprime en el archivo los datos de la fila completa

            Close ' cierra el archivo 1

        End If

    Else: celda.Interior.Color = vbYellow 'si no hay datos en celdas CODIGO , lo pintará de color amarillo

    End If

Next celda ' siguiente celda a procesar

End Sub

Sub rngDelimitador()

'@dj.vivanco

'ver 2.0.0 11-05-2021

Dim rng As Range, celda As Range, uf As Long, col As Integer

Dim rngFila As Variant, datosFila As Variant

Dim nomArchivo As String, Carpeta As String

'RUTA COMPLETA AQUI***************************************************

miCarpeta = "D:\desde_laptop\captain\"

'*********************************************************************

Set rng = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)

For Each celda In rng

    If celda.Value <> vbNullString Then 'si hay datos sigue:

        nomArchivo = celda.Value 'nombre de archivo

        interno = "SET FORCE_SIP_USERNAME " & """" & celda.Offset(0, 1).Value & """"

        Password = "SET FORCE_SIP_PASSWORD " & """" & celda.Offset(0, 2).Value & """"

        nombre = "SET FORCE_SIP_EXTENSION " & """" & celda.Offset(0, 3).Value & """"

        Open miCarpeta & nomArchivo & ".txt" For Append As #1 'abre el archivo txt como numero 1

        Print #1, interno

        Print #1, Password

        Print #1, nombre

        Close ' cierra el archivo

    End If

Next celda ' siguiente celda a procesar

End Sub