Macro para copiar formatos de columna y pegarla en varias columnas de una misma hoja
Para: Dante
Nuevamente recurriendo a tu asombrosa ayuda, con respecto a la macro que me diste, esta realiza bien su trabajo, pero le falta dos detalles la primera es que no me actualiza los nombres de la semana, Fila 5 y el segundo seria que al ejecutar la macro que me diste jale también sus bornes respectivos.
La macro que me diste fue la siguiente.
Sub PonerFechas()
'Por.Dante Amor
On Error Resume Next
Set h1 = Sheets("INGRESO DATOS")
ci = h1.Cells(60, Columns.Count).End(xlToLeft).Column
For Each h In Sheets
If InStr(1, h.Name, ".") > 0 Then
n = h.Name
Set b = Rows(6).Find(n)
If b Is Nothing Then
u = h1.Cells(6, Columns.Count).End(xlToLeft).Column + 1
h1.Cells(6, u) = n
End If
End If
Next
h1.Range(h1.Cells(60, ci), h1.Cells(151, ci)).Select
Selection.AutoFill Destination:=h1.Range(h1.Cells(60, ci), h1.Cells(151, u)), Type:=xlFillDefault
End Sub
Bueno.
1 Respuesta
Te anexo la macro con los cambios
Sub PonerFechas()
'Por.Dante Amor
Set h1 = Sheets("INGRESO DATOS")
ci = h1.Cells(60, Columns.Count).End(xlToLeft).Column
For Each h In Sheets
If InStr(1, h.Name, ".") > 0 Then
n = h.Name
Set b = Rows(6).Find(n)
If b Is Nothing Then
u = h1.Cells(6, Columns.Count).End(xlToLeft).Column + 1
fec1 = Split(n, ".")
fec2 = DateSerial(fec1(2), fec1(1), fec1(0))
h1.Cells(6, u) = n
h1.Cells(5, u) = Format(fec2, "dddd")
End If
End If
Next
h1.Range(h1.Cells(60, ci), h1.Cells(151, ci)).Copy _
h1.Range(h1.Cells(60, ci), h1.Cells(151, u))
MsgBox "fin"
End SubSaludos.Dante Amor
No olvides valorar la respuesta.
Hola! Dante
Muchísimas gracias funciona excelente pero en la fila 6 los nombres de la semana, esta me las pone en minúsculas y no en mayúsculas.
Cambia en la macro, esta línea
h1.Cells(5, u) = Format(fec2, "dddd")
Por esta
h1.Cells(5, u) = UCase(Format(fec2, "dddd"))
¡Gracias! Dante
Ahora si funciona perfectamente pero al ejecutar doble vez la macro esta me manda error 1004 y me pone de amarillo lo siguiente.
h1.Range(h1.Cells(60, ci), h1.Cells(151, ci)).Copy _ h1.Range(h1.Cells(60, ci), h1.Cells(151, u))
Bueno al inicio de la macro le agregue "On Error Resume Next" y me trabaja perfectamente no se si es correcto hacer esto o hay otra opción para que no me salga este error.
