Recorrer filas y copiar en nueva hoja datos

[KRUGERS]

Buenos días:

Intento copiar en una nueva hoja una serie de datos cuando estos cambian:

En la Hoja1, tengo cuatro columnas con NUMERO, APELLIDOSYNOMBRE, FECHA y SEMANA. Los datos están ordenados por SEMANA.

Necesito copiar en una hoja nueva llamada "SEMANA_X" los datos de cada semana por separado, es decir:

En una nueva hoja llamada "SEMANA_01", copiar los datos de todas las filas de la columna SEMANA con el valor 1; en otra nueva hoja llamada "SEMANA_02", copiar los datos de todas las filas de la columna SEMANA con el valor 2, y así sucesivamente hasta que no haya datos en la columna SEMANA.

Me he metido en un bucle con do while y for next...con if y me he perdido. ¿Podrías echarme una mano? Muchas gracias a todos por anticipado.

Os adjunto el archivo.

Importadas de Access Toshiba - copia.xlsm

[Pirtrafilla]

A ver que tal esto. Seguro que se puede acortar, soy bastante novato.

Sub Macro1()
Sheets("Hoja1").Select
fila = ActiveSheet.Cells(Rows.Count, "F").End(xlUp).Row
ultimo = WorksheetFunction.Max(ActiveSheet.Range("F2:F" & fila))
'
For c = 1 To 3 'ultimo
  Sheets("Hoja1").Activate
    Range("A1:F1").AutoFilter
    Selection.AutoFilter Field:=6, Criteria1:=c
    filab = ActiveSheet.Cells(Rows.Count, "F").End(xlUp).Row
    Range("a1:F" & filab).CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
    Worksheets.Add.Name = "SEMANA_" & c
  Sheets("SEMANA_" & c).Cells(1, 1).PasteSpecial xlPasteValues
  Sheets("SEMANA_" & c).Range("D:E").Columns.Insert
Next
'
For Each Hoja In Sheets
    If Hoja.AutoFilterMode Then Hoja.AutoFilterMode = 0
Next
Sheets("Hoja1").Select
'
End Sub

 

[Pirtrafilla]

Hace 3 minutos , Pirtrafilla dijo:

For c = 1 To 3 'ultimo

Cambia lo citado por esto otro. Había puesto 3 para probar, pero lo correcto es el valor de la variable. 

For c = 1 To ultimo

[KRUGERS]

Gracias por la respuesta. De momento no funciona. Mañana te cuento.

[Pirtrafilla]

A mi me funciona, según creo entender lo que quieres. Lo que si veo que el formato de la columna C no lo daba como fecha, así que lo he modificado para que tenga en cuenta este detalle. Te reenvío el código modificado y ya dirás si te sirve de ayuda.

Sub Macro1()
Sheets("Hoja1").Select
fila = ActiveSheet.Cells(Rows.Count, "F").End(xlUp).Row
ultimo = WorksheetFunction.Max(ActiveSheet.Range("F2:F" & fila))
'
For c = 1 To ultimo
  Sheets("Hoja1").Activate
    Range("A1:F1").AutoFilter
    Selection.AutoFilter Field:=6, Criteria1:=c
    filab = ActiveSheet.Cells(Rows.Count, "F").End(xlUp).Row
    Range("a1:F" & filab).CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
    Worksheets.Add.Name = "SEMANA_" & c
With Sheets("SEMANA_" & c)
  .Cells(1, 1).PasteSpecial xlPasteValues
  .Range("D:E").Columns.Insert
  .Columns("C").Select
  Selection.NumberFormat = "dd/mm/yyyy"
  .Cells(1, 1).Select
End With
Next
'
For Each Hoja In Sheets
    If Hoja.AutoFilterMode Then Hoja.AutoFilterMode = 0
Next
Sheets("Hoja1").Select
'
End Sub

Moisés.

[KRUGERS]

Hola de nuevo Pirtrafilla:

Ya funciona!! Gracias por dedicarle tu tiempo.

He modificado solamente dos o tres líneas y ahora sí me funciona.

El código ahora es este. Prácticamente como lo habías creado. Doy por cerrado el tema. Un saludo.

Sheets("Hoja1").Select
Selection.CurrentRegion.Select
    Columns("A:F").EntireColumn.AutoFit
fila = ActiveSheet.Cells(Rows.Count, 6).End(xlUp).Row
ultimo = WorksheetFunction.Max(ActiveSheet.Range("F2:F" & fila))
'
For c = 1 To ultimo
  Sheets("Hoja1").Activate
    Range("A1:F1").AutoFilter
    Selection.AutoFilter Field:=6, Criteria1:=c
    filab = ActiveSheet.Cells(Rows.Count, 6).End(xlUp).Row
    Range("A1:F" & filab).CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "SEMANA_" & c
With Sheets("SEMANA_" & c)
  .Cells(1, 1).PasteSpecial xlPasteValues
  .Range("C:C, E:E").Select
   Selection.NumberFormat = "dd/mm/yyyy"
   Selection.CurrentRegion.Select
    Columns("A:F").EntireColumn.AutoFit
  .Cells(1, 1).Select
End With
Next
'
For Each Hoja In Sheets
    If Hoja.AutoFilterMode Then Hoja.AutoFilterMode = 0
Next
Worksheets("Hoja1").Select
Cells(1, 1).Select
'
End Sub

[Pirtrafilla]

@KRUGERS, gracias a ti.

Ya ves que estoy aprendiendo, se nota que soy novato.

Si te es suficiente ya es más que gratificante.

Te recomiendo si pasas por el foro a menudo te fijes como dominan VBA los administradores y la mayoría de colaboradores. Solo de echar un vistazo se disfruta y se aprende, si encima recibes ayuda ya es muchísimo.

Mi código es muy simple, cualquier de los administradores lo habrían reducido mucho más. Solo hay que echar un vistazo a sus post.

Un abrazo.

 

[Antoni]

No es la macro mas rápida del mundo, pero funciona.

Sub SepararSemanas(): On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For x = 1 To 52
   Sheets("SEMANA " & Format(x, "00")).Delete
   Sheets.Add.Name = "SEMANA " & Format(x, "00")
   Hoja1.Rows(1).Copy Rows(1)
   Hoja1.Select
Next
For x = 2 To Range("A" & Rows.Count).End(xlUp).Row
   Set semana = Sheets("SEMANA " & Format(Range("F" & x), "00"))
   Rows(x).Copy semana.Rows(semana.Range("A" & Rows.Count).End(xlUp).Row + 1)
Next

 

[Pirtrafilla]

@Antoni, ¡que bien!

Muchas gracias, un placer aprender de ti.

Moisés.

 

 

[Pirtrafilla]

Ahora me acabo de dar cuenta que todas las columnas contenían datos, no me había fijado que las columnas D:E no estaban vacías.

Las estaba añadiendo sin poner datos.

Moisés.

 

[KRUGERS]

Gracias Antoni. Siempre estás pendiente. Lo probaré, a ver si no se ralentiza mucho cuando la aplique a una hoja con unas 10000 filas

Sí, Moisés. Por eso eliminé de tu código la línea

.Range("D:E").Columns.Insert

[KRUGERS]

Antoni y Moisés, gracias por vuestra desinteresada colaboración.

Ambas macros funcionan perfectamente. Un saludo