Copiar parte de los registros de una columna a columna

Podrían ayudar con código de macros... Que pueda copiar parte de los registros de una columna a otra columna de la misma hoja de trabajo ... Como se ve en el siguiente ejemplo

debiendo que dar como se en el el siguiente imagen

dejo el archivo para verlo: https://docs.google.com/spreadsheets/d/1Q8MnRmhBqPC_nu4u-4JeUNx6t88U-jYC/edit?usp=sharing&ouid=109258364453015021448&rtpof=true&sd=true 

2 Respuestas

Respuesta
3

Te dejo la macro que solicitas.

Entra al Editor de macros (desde menú Programador/Desarrollador o con el atajo ALT +F11)

Inserta un módulo y allí pega el siguiente código:

Sub ajusteHoja()
'x Elsamatilde
Application.ScreenUpdating = False
'se quitan posibles filtros
If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
'Se trabaja en hoja activa, a partir de fila 2 hasta la última según col E
x = Range("E" & Rows.Count).End(xlUp).Row
'se agrega una col delante de F para la fecha
Columns("F:F").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'se recorren las filas
For i = 3 To x
    'se copia el contenido de la col E en la F de la fila anterior
    Range("E" & i).Copy Destination:=Range("F" & i - 1)
    'se elimina la fila activa, restando 1 a la variable de fin de rango
    Range("E" & i).EntireRow.Delete xlUp
    x = x - 1
Next i
MsgBox "Fin del proceso.", , "Información"
End Sub

Cada línea va explicada por lo que no tendrás inconvenientes en comprender el código.

Como es posible que el proceso se demore unos segundos, espera al mensaje de finalizado antes de realizar cualquier acción o cambio de hojas.

Puedo enviarte el libro con la macro ya ejecutada, los correos están en mi sitio que dejo al pie.

Respuesta
2

Aquí otra macro a considerar.

El proceso lo realiza en memoria.

Sub CopiarColumna()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, m As Long
  If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
  a = Range("A2:O" & Range("E" & Rows.Count).End(3).Row).Value
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2) + 1)
  For i = 1 To UBound(a, 1) Step 2
    k = k + 1
    m = 0
    For j = 1 To UBound(a, 2)
      m = m + 1
      b(k, m) = a(i, j)
      If j = 5 Then
        m = m + 1
        b(k, m) = a(i + 1, j)
      End If
    Next
  Next
  Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
  Range("G1").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromRightOrBelow
  MsgBox "Fin"
End Sub

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas