Saltar al contenido

Ordenar números en otra hoja


Wpb23

Recommended Posts

publicado

Buenos días,

Aquí me encuentro de nuevo, pidiendo vuestra ayuda.

Tengo que ordenar números de tal forma que recorra cada columna que tenga datos, los copie, y pegue los valores en una única columna.

El código que estoy trabajando es el siguiente:

Dim num As String

num = 11

Windows("CopyPS_prueba.xlsm").Activate

Rows("10:10").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
ActiveSheet.Range("B11", ActiveSheet.Range("b11").End(xlDown)).Select
Selection.Copy
Windows("Libro1.xlsm").Activate
Range("A1").Select
ActiveSheet.Paste

Windows("CopyPS_prueba.xlsm").Activate
ActiveCell.Offset(0, 1).Select

Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(-1, 0).Activate
Loop

Cells(num, 3).Select

ActiveCell.End(xlDown).Select
Selection.Copy
Windows("Libro1.xlsm").Activate

Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Activate
Loop
ActiveSheet.Paste[/CODE]

De esta forma, le estoy diciendo que copie todo lo que encuentre y lo pegue en el libro1 en la columna A y vuelva al libro CopyPS_prueba y se coloque en la misma fila pero en la columna siguiente. El problema es que no sé como indicarle que se coloque en ese sitio y por eso he utilizado el Do while, y he añadido una fila entera vacía antes de comenzar todo el proceso.

Había pensado poner un bucle de Column.Index para que recorriera siempre desde la misma fila 11 a través de todas las columnas y probablemente no sea necesario tanto código.

A ver si podéis echarme un cable.

Os mando el adjunto.

Gracias de antemano.

Macro_autocompletar.xls

publicado

A ver si te sirve asi:

Sub MoveData()
Dim LC As Long, a As Long
LC = Cells(6, Columns.Count).End(xlToLeft).Column
For a = 1 To LC Step 1
Range(Cells(6, a), Cells(Cells(Rows.Count, 6).End(xlUp).Row, a)).Copy _
Cells(Cells(Rows.Count, LC + 2).End(xlUp).Row + 1, LC + 2)
Next a
Range("H1").Resize(4).Insert (xlShiftDown)
End Sub
[/CODE]

publicado

Buenas tardes Armando, gracias de antemano por tu tiempo.

Al probar la macro, me realiza lo que quiero, pero repite algunos valores, es decir, los coloca todos en la misma columna pero cuando termina vuelve a colocar los 8 primeros debajo, por lo que los ocho primeros aparecen dos veces.

Así queda el resultado cuando se ejecuta la macro:

13

15

17

5

8

150

10

40

30

10

16

19

25

17

18

19

26

13

15

17

5

8

150

10

40

Otra duda que me acaba de surgir, la última línea de código, si necesito que se ordenen en otro libro de excel, ¿que debería añadirle?

Gracias.

publicado

En el ejemplo funciona bien, como puedes verificarlo en el que subi, si esta en otro libro solo viendolo puedo revisarlo.

La ultima linea no ordena, solo coloca el resultado a la altura que mostraste en tu ejemplo.

Copia manualmente al otro libro con la grabadora encendida y sube el libro donde grabes el codigo para depurarlo.

publicado

El código de copiar manualmente:

ange("A6").Select
Selection.Copy
Windows("Libro1").Activate
ActiveSheet.Paste
Windows("Macro_compilación.xlsx").Activate
Range("B6").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Libro1").Activate
Range("A2").Select
ActiveSheet.Paste
Windows("Macro_compilación.xlsx").Activate
Range("C6").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Libro1").Activate
Range("A3").Select
ActiveSheet.Paste
Windows("Macro_compilación.xlsx").Activate
Range("D6:D7").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Libro1").Activate
Range("A4").Select
ActiveSheet.Paste
Windows("Macro_compilación.xlsx").Activate
Range("E6:E9").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Libro1").Activate
Range("A6").Select
ActiveSheet.Paste
Windows("Macro_compilación.xlsx").Activate
Range("F6:F13").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Libro1").Activate
Range("A10").Select
ActiveSheet.Paste[/CODE]

Te adjunto el libro dónde guarde la macro

test_juntar.xls

publicado

Debe hacerse en el libro origen y quedara akgo asi:

Sub Macro1()
'
' Macro1 Macro
'

'
Selection.Copy
Windows("wpv.xlsx").Activate
Range("A2").Select
ActiveSheet.Paste
Windows("ColsMul2single.xls").Activate
End Sub
Sub depurada()
Selection.Copy
Windows("wpv.xlsx").Activate
Range("A2").Select
ActiveSheet.Paste
'Windows("ColsMul2single.xls").Activate
End Sub
[/CODE]

publicado

No entiendo porque pones dos veces lo mismo en el código. Y eso es únicamente un copy-paste no?

Probablemente yo no me haya explicado bien. Lo que necesito es ordenarlos pero en otro libro, por tanto, no sé si se podría utilizar la función "resize" pero haciendo referencia a otro libro.

Cuando tiene los valores, ponerle en el código algo como:

Windows("Libro1.xlsm").Activate

Sheets("Hoja1").Range("A1").Resize(4).Insert (xlShiftDown)[/CODE]

Para que los ordene en el otro libro.

publicado

Son 2 codigos, el primero es el obtenido con la grabadora y en el segundo solo removi las lineas sobrantes.

El resize lo use para alinear, quiza no lo necesites en el otro libro.

Podemos hacer lo siguiente:

1. Corre la macro en el libro original

2. Enciende la grabadora

3. Copia manualmente el rango generado

4. Pegalo y ordenalo en el otro libro

5. Graba ambos libros

6. Apaga la grabadora

7. Sube el libro original con el codigo de la grabadora

Con eso depurare el codigo de la grabadora y lo integrare al codigo inicial.

publicado

El código generado:

Sub MoveData2()
'
' MoveData2 Macro
'

'
Range("L2:L18").Select
Selection.Copy
Windows("MoveData2.xls").Activate
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWorkbook.Save
ActiveWindow.Close
ChDir "C:\Users\Desktop"
End Sub[/CODE]

Macro_compilación2.xls

Archivado

Este tema está ahora archivado y está cerrado a más respuestas.

  • 109 ¿Te parecen útiles los tips de las funciones? (ver tema completo)

    1. 1. ¿Te parecen útiles los tips de las funciones?


      • No
      • Ni me he fijado en ellos

  • Ayúdanos a mejorar la comunidad

    • Donaciones recibidas este mes: 0.00 EUR
      Objetivo: 130.00 EUR
  • Archivos

  • Estadísticas de descargas

    • Archivos
      187
    • Comentarios
      97
    • Revisiones
      29

    Más información sobre "Un juego del Rabino en Excel"
    Última descarga
    Por pegones1

    2    1

  • Crear macros Excel

  • Mensajes

    • Que tal nuevamente,  adjunto una solución alternativa: =MAX(A:.A)-BYROW(F4:.AK20,LAMBDA(r,BUSCAR(2,1/(r=0),F3:.AK3))) Cabe mencionar que esta solución requiere funciones nuevas como RECORTAR.RANGO. CONTADOR FINAL (Solucion).xlsb
    • Buenos días,  espero se encuentren bien de salud compañeros, Favor me podrían ayuda con lo siguientes como se podría hacer cuando tengo una tabla dinámica que  amedida que se aumente las columnas fechas con data un formula que se coloco al final busque o analice siempre la ultima fila y columna de la fecha. Coloco un ejemplo
    • @JSDJSD Excelentes, GRACIAS POR TU SOPORTE , me ayudo demasiado es exactamente lo que quería. 5 ESTRELLAS
    • 'Opción 1 Sub FiltrarSKUPorFecha(): Application.ScreenUpdating = False Dim ultimaFila As Long, fila As Long Dim diccionarioSKU As Object Dim listaEliminar As Object Dim fechaActual As String, fechaSiguiente As String Dim f As Variant With Sheets("Consolidado") ultimaFila = .Cells(.Rows.Count, 1).End(xlUp).Row ' Crear diccionarios para comparar SKU y almacenar filas a eliminar Set diccionarioSKU = CreateObject("Scripting.Dictionary") Set listaEliminar = CreateObject("Scripting.Dictionary") ' Recorrer desde la primera fila hasta la penúltima For fila = 2 To ultimaFila - 1 fechaActual = .Cells(fila, 1).Value fechaSiguiente = .Cells(fila + 1, 1).Value ' Solo comparar la fecha actual con la siguiente (inmediatamente superior) If fechaActual <> fechaSiguiente Then diccionarioSKU.RemoveAll ' Limpiar el diccionario antes de llenarlo ' Guardar los SKU de la fecha siguiente (solo de la siguiente) For f = fila + 1 To ultimaFila If .Cells(f, 1).Value <> fechaSiguiente Then Exit For diccionarioSKU(.Cells(f, 2).Value) = 1 Next f ' Revisar los SKU de la fecha actual y marcar los que deben eliminarse For f = fila To 2 Step -1 If .Cells(f, 1).Value <> fechaActual Then Exit For ' Solo eliminar si el SKU no está en la fecha siguiente If Not diccionarioSKU.exists(.Cells(f, 2).Value) Then listaEliminar(f) = 1 ' Marcar fila para eliminar después End If Next f ' Ya no es necesario seguir buscando después de comparar la primera y la siguiente fecha Exit For End If Next fila ' Eliminar las filas marcadas sin afectar el bucle principal For Each f In listaEliminar.keys .Rows(f).Delete Next End With MsgBox "Completado correctamente.", vbInformation End Sub 'Opción 2 Sub FiltrarSKUPorFecha1(): Application.ScreenUpdating = False Dim ultimaFila As Long, fila As Long Dim listaEliminar As Collection Dim fechaActual As String, fechaSiguiente As String Dim f As Variant, i As Long Dim SKUExiste As Boolean With Sheets("Consolidado") ultimaFila = .Cells(.Rows.Count, 1).End(xlUp).Row ' Inicializar la colección para marcar las filas a eliminar Set listaEliminar = New Collection ' Recorrer desde la primera fila hasta la penúltima For fila = 2 To ultimaFila - 1 fechaActual = .Cells(fila, 1).Value fechaSiguiente = .Cells(fila + 1, 1).Value ' Solo comparar la fecha actual con la siguiente (inmediatamente superior) If fechaActual <> fechaSiguiente Then ' Revisar los SKU de la fecha actual y marcar los que deben eliminarse For f = fila To 2 Step -1 If .Cells(f, 1).Value <> fechaActual Then Exit For ' Comprobar si el SKU está en la fecha siguiente SKUExiste = False For i = fila + 1 To ultimaFila If .Cells(i, 1).Value <> fechaSiguiente Then Exit For If .Cells(i, 2).Value = .Cells(f, 2).Value Then SKUExiste = True Exit For End If Next i ' Si el SKU no se encuentra en la fecha siguiente, marcar para eliminar If Not SKUExiste Then listaEliminar.Add f ' Marcar fila para eliminar después End If Next f ' Ya no es necesario seguir buscando después de comparar la primera y la siguiente fecha Exit For End If Next fila ' Eliminar las filas marcadas sin afectar el bucle principal For Each f In listaEliminar .Rows(f).Delete Next f End With MsgBox "Completado correctamente.", vbInformation End Sub   TABLA ELIMINAR.xlsm
  • Visualizado recientemente

    • No hay usuarios registrado para ver esta página.
×
×
  • Crear nuevo...

Información importante

Echa un vistazo a nuestra política de cookies para ayudarte a tener una mejor experiencia de navegación. Puedes ajustar aquí la configuración. Pulsa el botón Aceptar, si estás de acuerdo.