Cambio de ruta auotmatico al cambiar el mes?

Esta es la marco que uso actualmente.

Private Sub commandbutton1_click()
nombre = Cells(7, 4).Value
folio = Cells(5, 13).Value
fecha = Cells(7, 13).Value

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"\\192.168.1.XXX\Ordenes de Compra\EMPRESA\Julio2017\" & nombre & " " & folio & " .pdf", Quality:= _
xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
Application.DisplayAlerts = False
ActiveSheet.Unprotect "Fulcrum07"
Range("M5").Value = Range("M5").Value + 1
ActiveSheet.Protect "Fulcrum07"
Range("C11:J11,C12:J12,C13:J13,C14:J14,C15:J15,C16:J16,C17:J17,C18:J18,C19:J19,C20:J20,D24:N24,C25:N25,C26:N26,C27:N27,M11:M20"). ClearContents
ActiveWorkbook.Save
strReportName = "\\192.168.1.XXX\Ordenes de Compra\EMPRESA\OrdendeCompra_Jorge Suarez.xlsm"
Dim objOutlook As Object
Dim objMail As Object
Dim objOutlookAttach As Object
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(olMailItem)
Set objOutlookAttach = objOutlook.CreateItem(olAttachMents)
With objMail
'A quien va dirigido el correo
.To = ""
.CC = ""
.CC = ""
.BCC = ""
'Se especifica el asunto
.Subject = " O.C. De " & fecha & nombre & folio
'Se escriben el o los archivos a adjuntar en el mail
.Attachments.Add "\\192.168.1.XXX\Ordenes de Compra\EMPRESA\Julio2017\" & nombre & " " & folio & " .pdf"
.Body = "Se anexa orden de compra favor de confirmar recepción"
'Se manda el mensaje
.Send
End With
'Se cierran todos los objetos utilizados
Set objMail = Nothing
Set objOutlook = Nothing

ActiveWorkbook.Close

End Sub

Por el momento lo guarda en la carpeta Julio2017 pero al llegar al 01 de Agosto, quiero que en automático lo guarde en Agosto2017.

Las carpetas ya las tengo creadas en el servidor.

1 Respuesta

Respuesta
2

Te anexo la macro actualizada, también cuando llegues a enero de 2018, la macro pondrá "enero2018"

Private Sub commandbutton1_click()
    nombre = Cells(7, 4).Value
    folio = Cells(5, 13).Value
    fecha = Cells(7, 13).Value
    mes = Format(Date, "mmmm")
    año = Year(Date)
    ruta = "\\192.168.1.XXX\Ordenes de Compra\EMPRESA\" & mes & año & "\"
    '
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=ruta & nombre & " " & folio & " .pdf", _
        Quality:=xlQualityStandard, IncludeDocProperties:=False, _
        IgnorePrintAreas:=False, OpenAfterPublish:=True
    Application.DisplayAlerts = False
    ActiveSheet.Unprotect "Fulcrum07"
    Range("M5").Value = Range("M5").Value + 1
    ActiveSheet.Protect "Fulcrum07"
    Range("C11:J11,C12:J12,C13:J13,C14:J14,C15:J15,C16:J16,C17:J17,C18:J18,C19:J19,C20:J20,D24:N24,C25:N25,C26:N26,C27:N27,M11:M20"). ClearContents
    ActiveWorkbook.Save
    strReportName = "\\192.168.1.XXX\Ordenes de Compra\EMPRESA\OrdendeCompra_Jorge Suarez.xlsm"
    Dim objOutlook As Object
    Dim objMail As Object
    Dim objOutlookAttach As Object
    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(olMailItem)
    Set objOutlookAttach = objOutlook.CreateItem(olAttachMents)
    With objMail
        'A quien va dirigido el correo
        .To = ""
        .CC = ""
        .CC = ""
        .BCC = ""
        'Se especifica el asunto
        .Subject = " O.C. De " & fecha & nombre & folio
        'Se escriben el o los archivos a adjuntar en el mail
        .Attachments.Add ruta & nombre & " " & folio & " .pdf"
        .Body = "Se anexa orden de compra favor de confirmar recepción"
        'Se manda el mensaje
        .Send
    End With
    'Se cierran todos los objetos utilizados
    Set objMail = Nothing
    Set objOutlook = Nothing
    ActiveWorkbook.Close
End Sub

.

'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias

.

Avísame cualquier duda

.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas