Macro para combinar datos de filas
Estoy realizando una BBDD y al trabajar con los datos en una hoja excel me veo en la necesidad de realizar la siguiente operación.
Tengo cientos de filas con un texto que contiene dos puntos y otras líneas que no contienen los dos puntos.
Lo que necesito es que las líneas que no contienen los dos puntos: a) se combinen y b) si fuera posible, que se combinen también con la fila anterior, que sí tiene dos puntos.
Pongo un ejemplo para verlo claro -cada linea es una fila. Todo en la columna A-:
Tengo:
----------
Nombre: perico perez
Dirección:
C/ CAPULETO, 69-9ºB
Observaciones:
Se fue a comprar tabaco
Y no volvió
Necesito:
-------------
Nombre: perico perez
Dirección: c/ capuleto, 69-9ºb
Observaciones: se fue a comprar tabaco y no volvió
Gracias por anticipado. Un saludo,
Bricomatica
Tengo cientos de filas con un texto que contiene dos puntos y otras líneas que no contienen los dos puntos.
Lo que necesito es que las líneas que no contienen los dos puntos: a) se combinen y b) si fuera posible, que se combinen también con la fila anterior, que sí tiene dos puntos.
Pongo un ejemplo para verlo claro -cada linea es una fila. Todo en la columna A-:
Tengo:
----------
Nombre: perico perez
Dirección:
C/ CAPULETO, 69-9ºB
Observaciones:
Se fue a comprar tabaco
Y no volvió
Necesito:
-------------
Nombre: perico perez
Dirección: c/ capuleto, 69-9ºb
Observaciones: se fue a comprar tabaco y no volvió
Gracias por anticipado. Un saludo,
Bricomatica
2 Respuestas
Respuesta de pitcher_
1
Ingresa este código :
Sub Nueva_Forma()
Dim Filas, Aux As Long
Aux = 0
For Filas = 1 To Range("A65535").End(xlUp).Row
If InStr(Cells(Filas, 1), ":") = 0 Then
Cells(Filas - 1, 2) = Cells(Filas - 1, 1) & " " & Cells(Filas, 1)
Else
Cells(Filas, 2) = Cells(Filas, 1)
If Aux = 1 Then
Cells(Filas - 3, 2) = "OBSERVACIONES: " & Cells(Filas - 2, 2)
Cells(Filas - 2, 2) = ""
Aux = 0
End If
If InStr(Cells(Filas, 1), "OBSERVACIONES:") > 0 Then
Aux = 1
End If
End If
Next Filas
Cells(Filas - 3, 2) = "OBSERVACIONES: " & Cells(Filas - 2, 2)
Cells(Filas - 2, 2) = ""
For Filas = 1 To Range("B65535").End(xlUp).Row
If Cells(Filas, 2) = "" Then
Cells(Filas, 2).Delete Shift:=xlUp
End If
Next Filas
For Filas = 1 To Range("B65535").End(xlUp).Row
If Cells(Filas, 2) = "" Then
Cells(Filas, 2).Delete Shift:=xlUp
End If
Next Filas
End Sub
Te cuento que tu formato debe estar en la columna A y el nuevo formato te lo dará en la columna B.
Espero que sea de tu ayuda. Cualquier consulta no dudes en preguntar.
Suerte.
Pitcher !
Sub Nueva_Forma()
Dim Filas, Aux As Long
Aux = 0
For Filas = 1 To Range("A65535").End(xlUp).Row
If InStr(Cells(Filas, 1), ":") = 0 Then
Cells(Filas - 1, 2) = Cells(Filas - 1, 1) & " " & Cells(Filas, 1)
Else
Cells(Filas, 2) = Cells(Filas, 1)
If Aux = 1 Then
Cells(Filas - 3, 2) = "OBSERVACIONES: " & Cells(Filas - 2, 2)
Cells(Filas - 2, 2) = ""
Aux = 0
End If
If InStr(Cells(Filas, 1), "OBSERVACIONES:") > 0 Then
Aux = 1
End If
End If
Next Filas
Cells(Filas - 3, 2) = "OBSERVACIONES: " & Cells(Filas - 2, 2)
Cells(Filas - 2, 2) = ""
For Filas = 1 To Range("B65535").End(xlUp).Row
If Cells(Filas, 2) = "" Then
Cells(Filas, 2).Delete Shift:=xlUp
End If
Next Filas
For Filas = 1 To Range("B65535").End(xlUp).Row
If Cells(Filas, 2) = "" Then
Cells(Filas, 2).Delete Shift:=xlUp
End If
Next Filas
End Sub
Te cuento que tu formato debe estar en la columna A y el nuevo formato te lo dará en la columna B.
Espero que sea de tu ayuda. Cualquier consulta no dudes en preguntar.
Suerte.
Pitcher !
Hola Pitcher,
Muchisísmas gracias por tu macro. Funciona al 99% . Sólo falta lo siguiente:
El texto que se haya debajo de Nombre:, Dirección:, Observaciones: u otra fila puede tener más de dos líneas.
Por ejemplo:
Teléfono:
1234566
34634653456
636534563456
23452542345
Y necesito que eso se convierta en:
Teléfono: 1234566 34634653456 636534563456 23452542345
Es decir que permita varias filas. Si tienes que dar una cifra, pongamos 10 filas.
Gracias otra vez. Un saludo muy cordial,
Bricomatica
Muchisísmas gracias por tu macro. Funciona al 99% . Sólo falta lo siguiente:
El texto que se haya debajo de Nombre:, Dirección:, Observaciones: u otra fila puede tener más de dos líneas.
Por ejemplo:
Teléfono:
1234566
34634653456
636534563456
23452542345
Y necesito que eso se convierta en:
Teléfono: 1234566 34634653456 636534563456 23452542345
Es decir que permita varias filas. Si tienes que dar una cifra, pongamos 10 filas.
Gracias otra vez. Un saludo muy cordial,
Bricomatica
Ok. Creo que este código te servirá.
Sub Nueva_Forma1()
Dim Filas, Aux, FilaAux, TexAux As Long
Dim Texto As String
Aux = 0
TexAux = 0
For Filas = 1 To Range("A65535").End(xlUp).Row
If InStr(Cells(Filas, 1), ":") = 0 Then
Texto = Texto & " " & Cells(Filas, 1)
If InStr(Cells(Filas + 1, 1), ":") > 0 Then
Aux = 1
TexAux = 0
Else
TexAux = 1
End If
End If
If Aux = 1 Then
Cells(FilaAux, 2) = Cells(FilaAux, 2) & " " & Texto
Texto = ""
Aux = 0
Else
If TexAux = 0 Then
Cells(Filas, 2) = Cells(Filas, 1)
FilaAux = Filas
End If
End If
Next Filas
Cells(FilaAux, 2) = Cells(FilaAux, 2) & " " & Texto
AuxCiclo = Range("B65535").End(xlUp).Row
For Filas = 1 To AuxCiclo
If Cells(Filas, 2) = "" Then
Cells(Filas, 2).Delete Shift:=xlUp
Filas = Filas - 1
AuxCiclo = AuxCiclo - 1
If Filas > AuxCiclo Then
Exit For
End If
End If
Next Filas
End Sub
Espero que sea de tu ayuda. Cualquier consulta no dudes en preguntar.
Suerte
Pitcher !
A y no olvides cerrar la pregunta si la respuesta fue de tu ayuda.
Sub Nueva_Forma1()
Dim Filas, Aux, FilaAux, TexAux As Long
Dim Texto As String
Aux = 0
TexAux = 0
For Filas = 1 To Range("A65535").End(xlUp).Row
If InStr(Cells(Filas, 1), ":") = 0 Then
Texto = Texto & " " & Cells(Filas, 1)
If InStr(Cells(Filas + 1, 1), ":") > 0 Then
Aux = 1
TexAux = 0
Else
TexAux = 1
End If
End If
If Aux = 1 Then
Cells(FilaAux, 2) = Cells(FilaAux, 2) & " " & Texto
Texto = ""
Aux = 0
Else
If TexAux = 0 Then
Cells(Filas, 2) = Cells(Filas, 1)
FilaAux = Filas
End If
End If
Next Filas
Cells(FilaAux, 2) = Cells(FilaAux, 2) & " " & Texto
AuxCiclo = Range("B65535").End(xlUp).Row
For Filas = 1 To AuxCiclo
If Cells(Filas, 2) = "" Then
Cells(Filas, 2).Delete Shift:=xlUp
Filas = Filas - 1
AuxCiclo = AuxCiclo - 1
If Filas > AuxCiclo Then
Exit For
End If
End If
Next Filas
End Sub
Espero que sea de tu ayuda. Cualquier consulta no dudes en preguntar.
Suerte
Pitcher !
A y no olvides cerrar la pregunta si la respuesta fue de tu ayuda.
Respuesta de emoren
1
Ok.