¿Macro para bajar datos que están separados por un "|"?

Tengo en mi column "AT" y "AU" datos; En mi columna "AU" tengo datos que están separados por un "|", así :

Lo que me gustaría que hiciera la macro es que los que están en la columna "AU" me los separe y me los pongo por debajo de forma de listado, pero que asu ves en la columna "AT" me ponga ese dato las veces que separa la columna "AU" de mandera que me quede así :

Se repitió tres veces el "LATAM-MÉXICO-RMT-144557-30" por que en la columna "AU" tenia tres datos que los separaba un "|", ¿me pudieran pasar el vba que me haga eso de esas dos columnas?

2 respuestas

Respuesta
1

[Hola 

Te paso la macro 

Sub SEPARA_CADENA()
'
'VALORA LA RESPUESTA PARA FINALIZAR
    Set h1 = Sheets("Hoja1")
    Set h2 = Sheets("Hoja2")
    '
    ini = 2 'fila inicio
    k = 1
    h2.Cells.ClearContents
    For i = ini To h1.Range("AT" & Rows.Count).End(xlUp).Row
        If InStr(1, h1.Cells(i, "AU"), "|") > 0 Then
            cad = Split(h1.Cells(i, "AU"), "|")
        For J = LBound(cad) To UBound(cad)
            h2.Cells(k, "A") = h1.Cells(i, "AT")
            h2.Cells(k, "B") = cad(J)
            k = k + 1
        Next J
        End If
    Next i
    '
    MsgBox "Fin"
End Sub

Hola muchas gracias si es lo que necesito solo tengo una pregunta :

Tengo varias celdas que no tiene un "|" solo viene una selección por ejemplo así

A1) Compromiso Social

A2) Compromiso Social

A3) Compromiso Social

A4) Compromiso Social

A5) Compromiso Social

Para esos casos me los elimina y empieza a contar desde donde encuentra un "|", y también en esos casos tnecesito que los deje como están.

Te paso la macro actualizada

Sub SEPARA_CADENA()
'
'VALORA LA RESPUESTA PARA FINALIZAR
    Set h1 = Sheets("Hoja1")
    Set h2 = Sheets("Hoja2")
    '
    ini = 2 'fila inicio
    k = 1
    h2.Cells.ClearContents
    For i = ini To h1.Range("AT" & Rows.Count).End(xlUp).Row
        If InStr(1, h1.Cells(i, "AU"), "|") > 0 Then
            cad = Split(h1.Cells(i, "AU"), "|")
            For j = LBound(cad) To UBound(cad)
                h2.Cells(k, "A") = h1.Cells(i, "AT")
                h2.Cells(k, "B") = cad(j)
                k = k + 1
            Next j
        Else
        '
        h2.Cells(k, "A") = h1.Cells(i, "AT")
        h2.Cells(k, "B") = h1.Cells(i, "AU")
        k = k + 1
        '
        End If
    Next i
    '
    h2.Cells.EntireColumn.AutoFit
    MsgBox "Fin"
End Sub
Respuesta
1

Este es el resultado de la macro

y esta es la macro

Option Base 1
Sub separar_palabras()
Set datos = Range("at1").CurrentRegion
With datos
    f = .Rows.Count: c = .Columns.Count
    ReDim matriz(f * 5, 2)
    Set datos = .Rows(2).Resize(f - 1, c)
    x = 1
    For i = 1 To f
        texto = .Cells(i, 2)
        separa = Split(texto, "|")
        For j = 0 To UBound(separa)
        matriz(x, 1) = .Cells(i, 1)
        matriz(x, 2) = Trim(separa(j))
         x = x + 1
        Next j
    Next i
    .Clear
    Set datos = .Resize(f * 5, 2)
    Range(.Address) = matriz
    .EntireColumn.AutoFit
End With
Erase matriz
Set datos = Nothing
End Sub

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas