ImportarTXT a hojas en XLS dependiendo del primer dato

Estimado:
Hice una macro en conjunto con un amigo.
Su funcionalidad es obtener la primera cadena del txt de cada fila, que corresponde al nombre de la hoja, a la cual se debe insertar lo demás datos de cada fila del txt.
El problema es que cuando inserta desde la segunda Hoja hacia adelante, va sumando las filas anteriores, Y necesito que en TODAS las hojas inserte desde B4, en forma dinámica, por cierto.
Sub llenar()
Set fso = CreateObject("Scripting.FileSystemObject")
Dim a As String
Dim l As Integer
l = 4 'es la fila
a = ActiveWorkbook.Path
Set archivo = fso.OpenTextFile(a + "/Datos.txt", 1)
'CICLO QUE LEE EL ARCHIVO.. AQUI DEBIERA NO ESTAR "l" (fila) PARA QUE ASI  NO SUME LOS REGISTROS
'EN LAS DEMAS HOJAS
    Do While Not archivo.AtEndOfStream
          a = archivo.readline()
         linea a, l
  '       MsgBox (a)
         l = l + 1
         'LLAMA A FUNCION SUMA
         For i = 1 To 8
        suma l, i, 2
    Next
    Loop
    archivo.Close
    MsgBox "Importado"
    'Dim i As Integer
    'For i = 1 To 7
    '    suma l, i, 2
    'Next
End Sub
'INSERTA EN CADA COLUMNA
Sub linea(ByVal a As String, ByVal fila As Integer)
    Dim columna As Integer
    columna = 1
    b = Split(a, ",")
    For i = 0 To UBound(b)
        If i = 0 Then
           ' MsgBox (b(i))
            'Sheets(b(i)).Select
            'Sheets(b(i)).Item
            If sheetExist(b(i)) Then
                Sheets(b(i)).Select
            Else
                Sheets.Add
                ActiveSheet.Name = b(i)
                  MsgBox "pagina creada"
            End If
        Else
            'MsgBox (b(i))
            Cells(fila, columna + i) = b(i)
           ' MsgBox Str(b(i))
        Cells(fila, columna + i).Interior.ColorIndex = 6  'Cambia a amarillo
        Cells(fila, columna + i) = b(i)
        End If
    Next
End Sub
Sub suma(ByVal fila As Integer, ByVal columna As Integer, ByVal i As Integer)
    aa = numeroALetra(columna + 1)
'   bb = numeroALetra(columna + i)
    aaa = Str(4)
    bbb = "=SUM(" & aa & aaa & ":" & aa & Str(fila - 1) & ")"
    bbb = Replace(bbb, " ", "")
    Cells(fila, columna + 1) = bbb
    Cells(fila, columna + 1).Interior.ColorIndex = 15
End Sub
Function sheetExist(ByVal sheetName As String)
Dim l As Boolean
    l = False
    For i = 1 To Sheets.Count
        If Sheets.Item(i).Name = sheetName Then
            l = True
        End If
    Next
    sheetExist = l
End Function
Function numeroALetra(ByVal numeri As Integer)
    Select Case numeri
        Case 1
        numeroALetra = "A"
        Case 2
        numeroALetra = "B"
        Case 3
        numeroALetra = "C"
        Case 4
        numeroALetra = "D"
        Case 5
        numeroALetra = "E"
        Case 6
        numeroALetra = "F"
        Case 7
        numeroALetra = "G"
        Case 8
        numeroALetra = "H"
        Case 9
        numeroALetra = "I"
        Case 10
        numeroALetra = "J"
        'etc....
    End Select
End Function
_______
Datos.txt: (en cada hoja del excel, necesito que me inserte desde B4, dinámicamente)
GENERAL LENG, 50, 45, 20, 40, 24, 10, 15, 23
GENERAL LENG, 30, 45, 20, 50, 24, 10, 45, 21
GENERAL LENG, 40, 45, 20, 30, 24, 10, 15, 12
GENERAL LENG, 60, 45, 20, 20, 24, 10, 35, 24
Prioritarios GENERAL LENG, 15, 20, 12, 16, 12, 11, 13, 34
Prioritarios GENERAL LENG, 10, 20, 16, 16, 12, 11, 16, 32
Prioritarios GENERAL LENG, 14, 10, 15, 16, 13, 11, 13, 11
Prioritarios GENERAL LENG, 18, 23, 12, 16, 14, 11, 17, 55
Prioritarios GENERAL LENG, 19, 20, 12, 16, 12, 11, 13, 55
PLANILLA EXTRA, 44, 20, 23, 24, 25, 11, 54, 33
PLANILLA EXTRA, 23, 32, 43, 22, 44, 12, 43, 22
De antemano, muchas gracias.
HC.

1 Respuesta

Respuesta
1
Según entiendo el problema radica en que para cada línea de tu TXT validas a que hoja deberán ir los datos. Si es así entonces lo único que te hace falta es que tu contador de línea sólo se incremente cuando la siguiente línea sea para la misma hoja y en caso contrario reiniciar tu contador.
Te dejo el código modificado.
Dim sUltimaHoja As String
Dim CntFilas As Integer
Sub Llenar()
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim sRuta As String
    Dim sLinea As String
    Dim sHoja() As String
    sRuta = ActiveWorkbook.Path
    Set archivo = fso.OpenTextFile(sRuta + "/Datos.txt", 1)
    Do While Not archivo.AtEndOfStream
        sLinea = archivo.readline()
        sHoja = Split(sLinea, ",")
        If UCase(sUltimaHoja) <> UCase(sHoja(0)) Then
            If Trim(sUltimaHoja) <> "" Then
                For i = 1 To 8
                    Suma CntFilas + 1, i, 2
                Next
            End If
            sUltimaHoja = sHoja(0)
            CntFilas = 4
        Else
            CntFilas = CntFilas + 1
        End If
        If Not SheetExist(sUltimaHoja) Then
            Sheets.Add
            ActiveSheet.Name = sUltimaHoja
        End If
        LlenaLinea sUltimaHoja, sLinea, CntFilas
    Loop
    'Para la última hoja
    For i = 1 To 8
        Suma CntFilas + 1, i, 2
    Next
    archivo.Close
    MsgBox "Importado"
End Sub
Sub LlenaLinea(ByVal sHoja As String, ByVal sLinea As String, ByVal nFila As Integer)
    Dim columna As Integer
    columna = 1
    Sheets(sHoja).Select
    b = Split(sLinea, ",")
    For i = 1 To UBound(b)
        Cells(nFila, columna + i) = b(i)
        Cells(nFila, columna + i).Interior.ColorIndex = 6
        Cells(nFila, columna + i) = b(i)
    Next
End Sub
Sub Suma(ByVal fila As Integer, ByVal columna As Integer, ByVal i As Integer)
    aa = NumeroALetra(columna + 1)
    aaa = Str(4)
    bbb = "=SUM(" & aa & aaa & ":" & aa & Str(fila - 1) & ")"
    bbb = Replace(bbb, " ", "")
    Cells(fila, columna + 1) = bbb
    Cells(fila, columna + 1).Interior.ColorIndex = 15
End Sub
Function SheetExist(ByVal sSheetName As String) As Boolean
    Dim sHoja As Worksheet
    SheetExist = False
    For Each sHoja In ActiveWorkbook.Worksheets
        If UCase(sHoja.Name) = UCase(sSheetName) Then
            SheetExist = True
            Exit For
        End If
    Next
End Function
Function NumeroALetra(ByVal Numeri As Integer) As String
    Select Case Numeri
        Case 1
            NumeroALetra = "A"
        Case 2
            NumeroALetra = "B"
        Case 3
            NumeroALetra = "C"
        Case 4
            NumeroALetra = "D"
        Case 5
            NumeroALetra = "E"
        Case 6
            NumeroALetra = "F"
        Case 7
            NumeroALetra = "G"
        Case 8
            NumeroALetra = "H"
        Case 9
            NumeroALetra = "I"
        Case 10
            NumeroALetra = "J"
            'etc....
    End Select
End Function
Si gustas te puedo enviar el archivo donde hice las pruebas.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas