Pasar datos de una hoja a varias en celdas designadas

[jmrc123]

Deseo enviar los datos de la hoja "Datos" a tantas hojas "Muestra" como filas estén llenas.

Se deben crear las hojas nombradas en función de la columna B de la hoja "Datos", P0403 en el ejemplo.

Se copian los datos en los lugares oscurecidos de la hoja "Muestra", atención que al final también hay algunas, como también dejé en el ejemplo de la hoja "P0403".

Tan solo dejar una macro, ya colocaré el botón.

Puede ser complejo al final de la hoja, con los datos de años anteriores, columnas N,O,P, ... de la hoja "Datos", porque cada año se añade una columna. Cojo el año del análisis de la casilla A1.

Gracias de antemano.

Evaluacion mensual.xls

[jmrc123]

SOLUCIONADO

Hecho a partir de una programacion anterior.

Seguramente se puede depurar un poco.

Básicamente, crea hojas nuevas con los codigos de una columna y coloca los datos que queremos en las celdas que le decimos.

La macro es:

Sub Pasar_datos()

'por.jmrc

Application.ScreenUpdating = False

'Hoja inicial

Set h1 = Sheets("Datos")

'Hoja formato

Set h2 = Sheets("plantilla")

'filas a copiar

filas = 1

'fila inicial a copiar

filini = 4

filas = filas - 1

h1.Select

numh = 1

For i = filini To Range("A" & Rows.Count).End(xlUp).Row

celda = "A4"

n = Sheets.Count

h2.Copy After:=Sheets(n)

ActiveSheet.Name = "p" & numh

h1.Range("B" & i).Copy

ActiveSheet.Range("G5").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

h1.Range("A" & i).Copy

ActiveSheet.Range("H5").PasteSpecial Paste:=xlPasteValues

h1.Range("D" & i).Copy

ActiveSheet.Range("G25").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

h1.Range("E" & i).Copy

ActiveSheet.Range("G24").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

h1.Range("F" & i).Copy

ActiveSheet.Range("G22").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

h1.Range("G" & i).Copy

ActiveSheet.Range("G29").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

h1.Range("H" & i).Copy

ActiveSheet.Range("G27").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

h1.Range("I" & i).Copy

ActiveSheet.Range("G34").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

h1.Range("J" & i).Copy

ActiveSheet.Range("G32").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

h1.Range("K" & i).Copy

ActiveSheet.Range("G12").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

h1.Range("L" & i).Copy

ActiveSheet.Range("G14").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

h1.Range("M" & i).Copy

ActiveSheet.Range("G19").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

h1.Range("N" & i).Copy

ActiveSheet.Range("B83").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

h1.Range("O" & i).Copy

ActiveSheet.Range("B82").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

h1.Range("P" & i).Copy

ActiveSheet.Range("B81").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

h1.Range("Q" & i).Copy

ActiveSheet.Range("B80").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

ActiveSheet.Name = Range("G5").Value

numh = numh + 1

i = i + filas

Next

Application.ScreenUpdating = True

MsgBox "Proceso de copiado de filas terminado", vbInformation, "COPIAR DATOS VDA"

' Borrar paginas plantilla y Datos

Sheets("plantilla").Select

Application.CutCopyMode = False

ActiveWindow.SelectedSheets.Delete

Sheets("Datos").Select

ActiveWindow.SelectedSheets.Delete

End Sub