¿Cómo separar en Excel texto en varias filas cuando una cadena de texto se repite varias veces dentro de una misma celda?
Para Dante Amor:
Cuando una celda tiene más de una cadena de texto con Univ Andres Bello, sólo se separa el texto de la primera cadena, no generando filas y columnas para las demás cadenas de texto.
Esto sucede cuando una publicación es de varias facultades o incluso de una misma facultad, pero los autores se ponen por separado, ya que pertenecen a distintos departamentos o centros asociados a la misma facultad.
La última versión de la macro es esta:
https://www.dropbox.com/s/5mrcb2fh8u802hf/Macro.txt?dl=0
El archivo con la data a tratar es este:
https://www.dropbox.com/s/qcxu7snfwjqwwg8/Data.xlsx?dl=0
Un caso de ejemplo:
Figura 1: Columna C1.
Los colores y negritas los agregué yo.
Figura 2. Esto hacía la macro antes.
Figura 3. Esto hace la macro actualmente.
Figura 4. Esto necesito que haga la macro ahora.
Como te fijas habían más autores de Univ Andres Bello que la macro no está detectando y por ende tampoco separando.
Figura 5. Así lo dejaría yo finalmente.
Pero para ello necesito que la macro deje los datos como muestra la figura anterior (Figura 4).
Espero que se entienda bien el problema y así puedas hacer los ajustes necesarios para esta macro por favor.
Quedo nuevamente muy agradecido.
Muchos saludos,
Víctor Rocco
H o l a:
Te anexo la macro para lo siguiente:
1. Separar el texto en caso de que en la C1 venga más de una vez "Univ Andres Bello"
2. Poner en negrita solamente lo que corresponde a esa línea, ya lo verás en el archivo que te envié.
Si requieres más cambios lo vemos en otra pregunta.
Sub SepararTexto()
'Por.Dante Amor
Application.ScreenUpdating = False
Set h1 = Sheets("Hoja1")
Set h2 = Sheets("Hoja2")
h2.Cells.Clear
co2 = "Q" 'columna destino resto
h1.Range("A1,J1,K1,N1,O1,X1").Copy h2.[A1]
h1.Range("Y1,Z1,AT1,AU1,AV1,BA1,BB1,BD1").Copy h2.Range(co2 & 1)
'
j = 2
univ = "Univ Andres Bello"
For i = 2 To h1.Range("A" & Rows.Count).End(xlUp).Row
texto = h1.Cells(i, "X")
nstart = 1
encontrado = False
Do While True
n = InStr(nstart, texto, univ)
If n > 0 Then
encontrado = True
nstart = n
ini = InStrRev(texto, "[", n)
If ini > 0 Then
fin = InStrRev(texto, "]", n)
If fin > 0 Then
n = fin
End If
autor = Mid(texto, ini + 1, fin + 1 - ini - 2)
autores = Split(autor, ";")
fin2 = InStr(n, texto, "[") - 1
If fin2 > 0 Then
resto = Mid(texto, n + Len(univ) + 4, fin2 - (n + Len(univ) + 5))
restos = Split(resto, ",")
Else
resto = Mid(texto, n + Len(univ) + 4)
restos = Split(resto, ",")
End If
'
For k = LBound(autores) To UBound(autores)
h2.Cells(j, "A") = h1.Cells(i, "A")
h2.Cells(j, "B") = h1.Cells(i, "J")
h2.Cells(j, "C") = h1.Cells(i, "K")
h2.Cells(j, "D") = h1.Cells(i, "N")
h2.Cells(j, "E") = h1.Cells(i, "O")
'h2.Cells(j, "F") = h1.Cells(i, "X") 'título C1
h1.Cells(i, "X").Copy h2.Cells(j, "F") 'título C1
'
'Poner negritas
nuevofin2 = fin2 - ini
With h2.Cells(j, "F").Characters(Start:=ini, Length:=nuevofin2).Font
.Name = "Calibri"
.FontStyle = "Negrita"
End With
'
h2.Cells(j, "G") = Trim(autores(k)) 'La primera parte
m = Columns("H").Column 'el resto
For l = LBound(restos) To UBound(restos)
h2.Cells(j, m) = Trim(restos(l))
m = m + 1
Next
h1.Range("Y" & i & ",Z" & i & ",AT" & i & ",AU" & i & ",AV" & i & _
",BA" & i & ",BB" & i & ",BD" & i).Copy h2.Range(co2 & j)
j = j + 1
Next
End If
Else
If encontrado = False Then
'No existe la univ, entonces se copian las columnas
h1.Range("A" & i & ",J" & i & ",K" & i & ",N" & i & ",O" & i & ",X" & i).Copy h2.Range("A" & j)
h1.Range("Y" & i & ",Z" & i & ",AT" & i & ",AU" & i & ",AV" & i & _
",BA" & i & ",BB" & i & ",BD" & i).Copy h2.Range(co2 & j)
j = j + 1
Exit Do
End If
End If
nstart = nstart + 1
If nstart > Len(texto) Then Exit Do
Loop
Next
Application.ScreenUpdating = True
MsgBox "Fin"
End Sub
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
