Pasar datos de cabeceras de una misma columna a una fila
Tengo datos exportados (más de 500) de un sistema de ventas y se presentan así:
A B C
1 Fecha Factura No Importe
2 10/10/14 25 150.00
3 Línea en Blanco
4 Monto Pagado
5 200.00
Este es un solo registro. Y así como éste tengo como 500.
La pregunta: Primero quiero eliminar todos los espacios en banco y Segundo que la cabecera Monto Pagado aparezca en la columna D.
Espero haber sido claro y de antemano gracias por su colaboración
1 Respuesta
Te anexo la macro para acomodar los datos
Sub PasarCabeceras()
'Por.Dante Amor
Application.ScreenUpdating = False
Range("D1") = "Monto Pagado"
For i = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
Select Case Left(Cells(i, "A"), 5)
Case "Fecha", "Monto", ""
Rows(i).Delete
Case Else
If Cells(i, "B") = "" Then
monto = Cells(i, "A")
Rows(i).Delete
Else
Cells(i, "D") = monto
End If
End Select
Next
Application.ScreenUpdating = True
MsgBox "Proceso terminado"
End SubSigue las Instrucciones para ejecutar la macro
- Abre tu archivo de excel
- Para abrir Vba-macros y poder pegar la macro, Presiona Alt + F11
- En el menú elige Insertar / Módulo
- En el panel del lado derecho copia la macro
- Para ejecutarla presiona F5
Gracias por la molestia pero no me funcionó la macro. Tal vez será porque no lo hice bien. Hay algún otro tipo de solución? Saludos.
Si tus datos no están como el ejemplo que pusiste, no va a funcionar.
Si quieres envíame tu archivo y reviso cómo están los datos y adapto la macro.
Se me ocurre otra opción, sin macros, ordenando los datos, pero si los datos no están como el ejemplo, tampoco te va a funcionar.
Ya te lo mande Dante. Muchas gracias por tu gentileza.
Esta es la macro para acomodar tus datos.
Sub PasarCabeceras()
'Por.Dante Amor
Application.ScreenUpdating = False
Set h = Sheets("Trabajo")
Set r = h.Columns("A")
Set b = r.Find("ID PED", lookat:=xlWhole)
If Not b Is Nothing Then
ncell = b.Address
Do
h.Range(h.Cells(b.Row + 3, "A"), h.Cells(b.Row + 4, "A")).Copy _
h.Cells(b.Row, "E")
h.Rows(b.Row + 2 & ":" & b.Row + 4).Clear
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
Application.ScreenUpdating = True
MsgBox "Proceso terminado"
End SubSaludos.Dante Amor
