Macro transponer cada por filas
Necesito una macro que todos los datos de una columna A que están ordenados cada 4 filas con: nombre, dirección, teléfono, espacio en blanco. Nombre2, direccion2, telefono2, espacio en blanco2. Nombre3, direccion3, telefono3, espacio en blanco3. Convertirlos a 3 columnas A(nombre), B(dirección), C(Teléfono) en otra hoja.
2 Respuestas
Respuesta de silvianu
1
Haber dejame ver si entendí, tienes en la columna A los datos de esta manera:
Nombre
Dirección
Teléfono
<celda vacia>
Nombre2
Direccion2
¿Telefono2
es así o entendí mal?
Nombre
Dirección
Teléfono
<celda vacia>
Nombre2
Direccion2
¿Telefono2
es así o entendí mal?
Así es lo entendiste bien, quisiera extraer esos datos a otra hoja con las tres columnas de nombre, dirección y teléfono. Gracias.
Si esto es así como te pregunté anteriormente esta seria la macro que ocuparías, la puedes ajustar según te convenga.
Sub transponer()
Dim band As Boolean
Dim cont As Integer
Dim a, b As Integer
band = True
A = 1 'controla renglones (indica que inicia en la fila 1)
b = 1 'controla renglones (indica que inicia en la fila 1)
Do
'Nombre de la hoja donde van los datos
Sheets("Hoja1").Select
If Cells(a, "A") <> "" Then
Range(Cells(a, "A"), Cells(a + 2, "A")).Select
Application.CutCopyMode = False
Selection.Copy
'Nombre de la hoja en donde se pegarán los datos
Sheets("Hoja2").Select
'la varible b controla las filas en donde se pegaran los valores
Cells(b, "A").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
a = a + 3
b = b + 1
cont = 0
Else
a = a + 1
cont = cont + 1
End If
'este if controla los espacios vacíos si hay más de 2 renglones continuos sin datos
'"indica" que ya no hay más datos para copiar en la columna y termina el proceso
If cont >= 2 Then
band = False
End If
Loop While band = True
End Sub
Sub transponer()
Dim band As Boolean
Dim cont As Integer
Dim a, b As Integer
band = True
A = 1 'controla renglones (indica que inicia en la fila 1)
b = 1 'controla renglones (indica que inicia en la fila 1)
Do
'Nombre de la hoja donde van los datos
Sheets("Hoja1").Select
If Cells(a, "A") <> "" Then
Range(Cells(a, "A"), Cells(a + 2, "A")).Select
Application.CutCopyMode = False
Selection.Copy
'Nombre de la hoja en donde se pegarán los datos
Sheets("Hoja2").Select
'la varible b controla las filas en donde se pegaran los valores
Cells(b, "A").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
a = a + 3
b = b + 1
cont = 0
Else
a = a + 1
cont = cont + 1
End If
'este if controla los espacios vacíos si hay más de 2 renglones continuos sin datos
'"indica" que ya no hay más datos para copiar en la columna y termina el proceso
If cont >= 2 Then
band = False
End If
Loop While band = True
End Sub
Respuesta de Cadipas spain
1
Prueba esta macro, teniendo en cuenta que los nombres de las hojas son HOJA1 y HOJA2 (que les puedes cambiar de nombre) y otra condición es que en la hoja dos, empieza a copiar desde la fila 2 (ya que entiendo que tiene títulos en la uno) y en la hoja 1 empiezan los nombres desde la fila 1, todo esto se puede cambiar
El valor xx=la fila en la que empieza a copiar los nombres en la hoja 2
el valor x=1 es la fila donde empiezan los nombres en la hoja 1
Sub Macro1()
Set h1 = Sheets("hoja1")
Set h2 = Sheets("hoja2")
xx = 2
h1.Select
For x = 1 To Range("a65000").End(xlUp).Row Step 3
h1.Range(Cells(x, 1), Cells(x + 2, 1)).Copy
h2.Cells(xx, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
xx = xx + 1
Next x
End Sub
El valor xx=la fila en la que empieza a copiar los nombres en la hoja 2
el valor x=1 es la fila donde empiezan los nombres en la hoja 1
Sub Macro1()
Set h1 = Sheets("hoja1")
Set h2 = Sheets("hoja2")
xx = 2
h1.Select
For x = 1 To Range("a65000").End(xlUp).Row Step 3
h1.Range(Cells(x, 1), Cells(x + 2, 1)).Copy
h2.Cells(xx, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
xx = xx + 1
Next x
End Sub