Copiar fecha en otra hoja

A tod@s:
Os cuento tengo 2 macros, una (FECHA) que me copia la fecha de la hoja "DATOS" a la hoja "RESUMEN" y otra (LANZAR CALCULOS) que me hace una serie de cálculos. La macro FECHA funciona perfectamente si la ejecuto sola, pero al añadirla a la macro (LANZAR CALCULOS) solo me funciona la macro de los cálculos la de fecha no... Y no se como hacerlo para que me funcione solo en una macro las dos operaciones.

FECHA

Sub FECHA()

Dim Celda As Range
Dim PALABRA As String

PALABRA = "*" & "??/??/????" & "*"

For Each Celda In Range("A1:K1")
If Celda.Value Like PALABRA Then
Celda.Select
'VVV = Celda.Address
Celda.Copy
'Worksheets("RESUMEN").Range(VVV).PasteSpecial xlPasteAll
vals = InStr(1, Celda.Value, "/")
vfech = Mid(Celda.Value, vals - 2, 10)
vfech = CDate(vfech)
vdia = Weekday(vfech, 5)
'VR = Cells(3, vdia + 1)
Worksheets("RESUMEN").Cells(3, vdia + 2).PasteSpecial xlPasteAll
End If
Next Celda

End Sub

LANZAR CALCULOS

Sub LanzarCalculos()

Mensaje = MsgBox("Desea borrar los datos existentes", vbQuestion + vbYesNo, "#FreelancerExcel")

If Mensaje = vbYes Then
'Limpiar datos anteriores en la hoja "RESUMEN"
Sheets("RESUMEN").Cells.ClearContents
cRESUMEN = 1
Else
cRESUMEN = Sheets("RESUMEN").Cells(4, Cells.Columns.Count).End(xlToLeft).Column + 1
End If

'Averiguar cual es la última fila de la hoja "DATOS"

uFila = Sheets("DATOS").Cells(Rows.Count, 1).End(xlUp).Row

fRESUMEN = 3

'Bucle para recorrer las filas y buscar las máquinas que tenemos en la columna 3.
For fDATOS = 1 To uFila
If Left(Sheets("DATOS").Cells(fDATOS, 3), 12) = "MOV-RISPACS-" Then
'Poner el nombre en la hoja "RESUMEN"
Sheets("RESUMEN").Cells(fRESUMEN, cRESUMEN) = Sheets("DATOS").Cells(fDATOS, 3)
'Sheets("RESUMEN").Cells(fRESUMEN, cRESUMEN + 1) = "Capacity"
'Localizar datos de esta máquina.
CalcularDatosMaquina2 (fDATOS), (fRESUMEN), (cRESUMEN)
fRESUMEN = fRESUMEN + 7
End If
Next

'Seleccionar la hoja "RESUMEN" para visualizar.
Sheets("RESUMEN").Select
Sheets("RESUMEN").Cells(1, 1).Select

'Si cRESUMEN es diferente de 1 ejecutar los siguiente.
If cRESUMEN <> 1 Then

'Ordenar los datos de acuerdo a las máquinas de la 1ª columna.
'Buscar la 1ª máquina de la columna 1 en la columna actual(cRESUMEN).
For f = 3 To 31 Step 7
If Cells(f, cRESUMEN) = Cells(3, 1) Then
'Si coincide copiamos los datos de la máquina a la fila 38.
Range(Cells(f, cRESUMEN), Cells(f + 5, cRESUMEN + 1)).Copy Cells(3, cRESUMEN + 2)
End If
Next
'Buscar la 2ª máquina de la columna 1 en la columna actual(cRESUMEN).
For f = 3 To 31 Step 7
If Cells(f, cRESUMEN) = Cells(10, 1) Then
'Si coincide copiamos los datos de la máquina a la fila 38.
Range(Cells(f, cRESUMEN), Cells(f + 5, cRESUMEN + 1)).Copy Cells(10, cRESUMEN + 2)
End If
Next
'Buscar la 3ª máquina de la columna 1 en la columna actual(cRESUMEN).
For f = 3 To 31 Step 7
If Cells(f, cRESUMEN) = Cells(17, 1) Then
'Si coincide copiamos los datos de la máquina a la fila 38.
Range(Cells(f, cRESUMEN), Cells(f + 5, cRESUMEN + 1)).Copy Cells(17, cRESUMEN + 2)
End If
Next
'Buscar la 4ª máquina de la columna 1 en la columna actual(cRESUMEN).
For f = 3 To 31 Step 7
If Cells(f, cRESUMEN) = Cells(24, 1) Then
'Si coincide copiamos los datos de la máquina a la fila 38.
Range(Cells(f, cRESUMEN), Cells(f + 5, cRESUMEN + 1)).Copy Cells(24, cRESUMEN + 2)
End If
Next
'Buscar la 5ª máquina de la columna 1 en la columna actual(cRESUMEN).
For f = 3 To 31 Step 7
If Cells(f, cRESUMEN) = Cells(31, 1) Then
'Si coincide copiamos los datos de la máquina a la fila 38.
Range(Cells(f, cRESUMEN), Cells(f + 5, cRESUMEN + 1)).Copy Cells(31, cRESUMEN + 2)
End If
Next
'Borrar las columnas cRESUMEN+2
Sheets("RESUMEN").Range(Cells(1, cRESUMEN), Cells(1, cRESUMEN + 2)).EntireColumn.Delete
End If
End Sub

1 respuesta

Respuesta
1

Feliz navidad

Por lo que pude ver rápido tu macro están bien tu error creo que estas aquí

Luego de copiar las fechas en esta parte le dice que limpie la hoja

Mensaje = MsgBox("Desea borrar los datos existentes", vbQuestion + vbYesNo, "#FreelancerExcel")

If Mensaje = vbYes Then
'Limpiar datos anteriores en la hoja "RESUMEN"
Sheets("RESUMEN"). Cells. ClearContents

Estas parte tendrás que ponerla al principio de la macro

¡Muchas Gracias! 

He hecho lo que me dices pero me sigue sin funcionar... Voy a seguir probando a ver si doy con la solución. De todos modos muchas gracias por el aporte!

Un saludo

Alberto

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas