Forum Discussion

karol polubinski's avatar
karol polubinski
Brass Contributor
May 22, 2018

Control button to create a one time folder, save with date and send work sheet to email

I have tried to write a long code, i ADMIT i AM A BEGINNER. Sub AFolderVBA2() Dim i As Integer For i = 1 To 5 MkDir "C:\Users\kapo\Desktop\Catering\Weekly food Order\" & Range("A" & i) Next i E...
Macros and VBA
Matt Mickle's avatar
Matt Mickle
Bronze Contributor
May 24, 2018

Try changing this procedure as follows:

 

Sub Save()

    'I have changed it to work sheet as I only want the order summary sheet to be saved with the currwent date of the order made.
    
    ActiveWorksheet.SaveAs Filename:="C:\Users\kapo\Desktop\Catering\Weekly food Order " & Format(Now(), "DD-MM-YYYY") & ".xlsm", FileFormat _
    :=xlOpenXMLWorksheetkMacroEnabled, CreateBackup:=False

End Sub
karol polubinski's avatar
karol polubinski
Brass Contributor
May 24, 2018

I am getting still Errors for some sort of unknown reason.

May be its the other button formulas that are malfunctioning?

I think I am not understanding well the book VBA code for dummies. 

So far each for each code and formula when I became too Difficult I had to ask for help.

at times I find writing a code not so logical.

Even my copy and paste code seems to be messed up.

Cannot attach the book as the website removes it 

 

 

Private Sub CommandButton3_Click()
Sub AFolderVBA2()

 Dim i As Integer
 
 For i = 1 To 5
 MkDir "C:\Users\kapo\Desktop\Suisca Catering\Weekly food Order\" & Range("A" & i)
 Next i

End Sub

Sub Save()
  ActiveWorksheet.SaveAs Filename:="C:\Users\kapo\Desktop\Catering\Weekly food Order " & Format(Now(), "DD-MM-YYYY") & ".xlsm", FileFormat _
 :=xlOpenXMLWorksheetkMacroEnabled, CreateBackup:=False

End Sub

Sub SendMail()

 Dim OutlookApp As Object
 Dim OutlookMail As Object
 Set OutlookApp = CreateObject("Outlook.Application")
 Set OutlookMail = OutlookApp.CreateItem(0)
 
 
 On Error Resume Next
 
 
 With OutlookMail
 .To = "campboss@suisca.com"
 .CC = ""
 .BCC = ""
 .Subject = "Weekly Order Note"
 .Body = "Good Day to All, Please find Attached order sheet for the week. Please Acknowledge reciept of the attached document, thank you. Best Regards, Camp Boss"
 .Attachments.Add Application.ActiveWorksheet.FullName '
 .Display
 
 End With
 
End Sub



Private Sub CommandButton4_Click()

 Range("G12").Copy
 Range("G2666").PasteSpecial Paste:=xlPasteFormats
 
 'Copy and PasteSpecial a between worksheets
 Worksheets("Sheet1").Range("A2").Copy
 Worksheets("Sheet4").Range("A2").PasteSpecial Paste:=xlPasteFormulas
 
 'Copy and PasteSpecial between workbooks
 Workbooks("Book1.xlsx").Worksheets("Sheet1").Range("A1").Copy
 Workbooks("Book2.xlsx").Worksheets("Sheet1").Range("A1").PasteSpecial Paste:=xlPasteFormats
 
 'Disable marching ants around copied range
 Application.CutCopyMode = False

End Sub
End Sub

Private Sub CommandButton5_Click()
Dim sbClearCellsOnlyData()
Range("G12:G2666").ClearContents
End Sub


Private Sub CommandButton6_Click()

End Sub

Private Sub CommandButton7_Click()

Application.Dialogs(xlDialogPrint).Show

End Sub

  • Matt Mickle's avatar
    Matt Mickle
    Bronze Contributor
    May 24, 2018

    Karol-

     

    Before attaching a file try using the VBA code below (You have Additional End Sub and Private Sub XXXX()  statements that needed to be removed.  They need to be paired together.)  If this code won't work then go ahead and use my below instructions to attach the file. :

     

    Sub AFolderVBA2()

 Dim i As Integer
 
 For i = 1 To 5
 MkDir "C:\Users\kapo\Desktop\Suisca Catering\Weekly food Order\" & Range("A" & i)
 Next i

End Sub

Sub Save()
  ActiveWorksheet.SaveAs Filename:="C:\Users\kapo\Desktop\Catering\Weekly food Order " & Format(Now(), "DD-MM-YYYY") & ".xlsm", FileFormat _
 :=xlOpenXMLWorksheetkMacroEnabled, CreateBackup:=False

End Sub

Sub SendMail()

 Dim OutlookApp As Object
 Dim OutlookMail As Object
 Set OutlookApp = CreateObject("Outlook.Application")
 Set OutlookMail = OutlookApp.CreateItem(0)
 
 
 On Error Resume Next
 
 With OutlookMail
 .To = "campboss@suisca.com"
 .CC = ""
 .BCC = ""
 .Subject = "Weekly Order Note"
 .Body = "Good Day to All, Please find Attached order sheet for the week. Please Acknowledge reciept of the attached document, thank you. Best Regards, Camp Boss"
 .Attachments.Add Application.ActiveWorksheet.FullName '
 .Display
 
 End With
 
End Sub

Private Sub CommandButton4_Click()

 Range("G12").Copy
 Range("G2666").PasteSpecial Paste:=xlPasteFormats
 
 'Copy and PasteSpecial a between worksheets
 Worksheets("Sheet1").Range("A2").Copy
 Worksheets("Sheet4").Range("A2").PasteSpecial Paste:=xlPasteFormulas
 
 'Copy and PasteSpecial between workbooks
 Workbooks("Book1.xlsx").Worksheets("Sheet1").Range("A1").Copy
 Workbooks("Book2.xlsx").Worksheets("Sheet1").Range("A1").PasteSpecial Paste:=xlPasteFormats
 
 'Disable marching ants around copied range
 Application.CutCopyMode = False

End Sub

Private Sub CommandButton5_Click()
Dim sbClearCellsOnlyData()
Range("G12:G2666").ClearContents
End Sub


Private Sub CommandButton7_Click()

Application.Dialogs(xlDialogPrint).Show

End Sub

     

    Try saving the file as an .xlsx.  Then post it to the forum along with the code you have written.  The forum doesn't allow you to attach macro enabled workbooks because of security risks.

    • karol polubinski's avatar
      karol polubinski
      Brass Contributor
      May 24, 2018

      here is the excel file save without Macro.

      please see attached

      Code Being used is as follows:

      if you look at my previous message you can see the error.

      Private Sub CommandButton3_Click()
      Sub AFolderVBA2()

      Dim i As Integer

      For i = 1 To 5
      MkDir "C:\Users\kapo\Desktop\Suisca Catering\Weekly food Order\" & Range("A" & i)
      C:\Users\kapo\Desktop\Suisca Catering\Weekly Food Order
      Next i

      End Sub

      Sub Save()

      ActiveWorksheet.SaveAs Filename:="C:\Users\kapo\Desktop\Catering\Weekly food Order " & Format(Now(), "DD-MM-YYYY") & ".xlsm", FileFormat _
      :=xlOpenXMLWorksheetkMacroEnabled, CreateBackup:=False

      End Sub

      Sub SendMail()

      Dim OutlookApp As Object
      Dim OutlookMail As Object
      Set OutlookApp = CreateObject("Outlook.Application")
      Set OutlookMail = OutlookApp.CreateItem(0)


      On Error Resume Next


      With OutlookMail
      .To = "campboss@suisca.com"
      .CC = ""
      .BCC = ""
      .Subject = "Weekly Order Note"
      .Body = "Good Day to All, Please find Attached order sheet for the week. Please Acknowledge reciept of the attached document, thank you. Best Regards, Camp Boss"
      .Attachments.Add Application.ActiveWorksheet.FullName '
      .Display

      End With

      End Sub

      • Matt Mickle's avatar
        Matt Mickle
        Bronze Contributor
        May 25, 2018

        Try using this code.  Not really sure what you want to do with the  AFolderVBA2 Procedure.  I wrote some notes in my comments that should help clarify what the code is doing....

         

        Private Sub CommandButton3_Click()
    'This calls the three procedures in sucession
    Call AFolderVBA2 'Create Folders
    Call SaveSht 'Save Worksheet
    Call SendMail 'Create Email and display it
End Sub

Sub AFolderVBA2()

Dim i As Integer

For i = 1 To 5

    'THis takes the values for Cells A1-A5 on the Order Summary Tab...
    'It doesn't look like this is what you should use...
    'What directories do you want created?

    MkDir "C:\Users\kapo\Desktop\Suisca Catering\Weekly food Order\" & Range("A" & i)
Next i



End Sub

Sub SaveSht()

'Save is a reserved word.  It's best not to name a procedure with this naming convention
'I have altered the procedure name to SaveSht

ActiveWorksheet.SaveAs Filename:="C:\Users\kapo\Desktop\Suisca Catering\Weekly food Order\" & Format(Now(), "DD-MM-YYYY") & ".xlsm", FileFormat _
:=xlOpenXMLWorksheetkMacroEnabled, CreateBackup:=False

End Sub

Sub SendMail()

Dim OutlookApp As Object
Dim OutlookMail As Object
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)

On Error Resume Next

With OutlookMail
    .To = "campboss@suisca.com"
    .CC = ""
    .BCC = ""
    .Subject = "Weekly Order Note"
    .Body = "Good Day to All, Please find Attached order sheet for the week. Please Acknowledge reciept of the attached document, thank you. Best Regards, Camp Boss"
    .Attachments.Add Application.ActiveWorksheet.FullName
    .Display
    '.Send 'uncomment this line if you want to send the email rather than display it...
End With

End Sub
    • karol polubinski's avatar
      karol polubinski
      Brass Contributor
      May 24, 2018

      here is the excel file save without Macro.

      please see attached

      Code Being used is as follows:

      if you look at my previous message you can see the error.

      Private Sub CommandButton3_Click()
      Sub AFolderVBA2()

      Dim i As Integer

      For i = 1 To 5
      MkDir "C:\Users\kapo\Desktop\Suisca Catering\Weekly food Order\" & Range("A" & i)
      C:\Users\kapo\Desktop\Suisca Catering\Weekly Food Order
      Next i

      End Sub

      Sub Save()

      ActiveWorksheet.SaveAs Filename:="C:\Users\kapo\Desktop\Catering\Weekly food Order " & Format(Now(), "DD-MM-YYYY") & ".xlsm", FileFormat _
      :=xlOpenXMLWorksheetkMacroEnabled, CreateBackup:=False

      End Sub

      Sub SendMail()

      Dim OutlookApp As Object
      Dim OutlookMail As Object
      Set OutlookApp = CreateObject("Outlook.Application")
      Set OutlookMail = OutlookApp.CreateItem(0)


      On Error Resume Next


      With OutlookMail
      .To = "campboss@suisca.com"
      .CC = ""
      .BCC = ""
      .Subject = "Weekly Order Note"
      .Body = "Good Day to All, Please find Attached order sheet for the week. Please Acknowledge reciept of the attached document, thank you. Best Regards, Camp Boss"
      .Attachments.Add Application.ActiveWorksheet.FullName '
      .Display

      End With

      End Sub

    • karol polubinski's avatar
      karol polubinski
      Brass Contributor
      May 24, 2018

      here is the excel file save without Macro.

      please see attached

      Code Being used is as follows:

      if you look at my previous message you can see the error.

      Private Sub CommandButton3_Click()
      Sub AFolderVBA2()

      Dim i As Integer

      For i = 1 To 5
      MkDir "C:\Users\kapo\Desktop\Suisca Catering\Weekly food Order\" & Range("A" & i)
      C:\Users\kapo\Desktop\Suisca Catering\Weekly Food Order
      Next i

      End Sub

      Sub Save()

      ActiveWorksheet.SaveAs Filename:="C:\Users\kapo\Desktop\Catering\Weekly food Order " & Format(Now(), "DD-MM-YYYY") & ".xlsm", FileFormat _
      :=xlOpenXMLWorksheetkMacroEnabled, CreateBackup:=False

      End Sub

      Sub SendMail()

      Dim OutlookApp As Object
      Dim OutlookMail As Object
      Set OutlookApp = CreateObject("Outlook.Application")
      Set OutlookMail = OutlookApp.CreateItem(0)


      On Error Resume Next


      With OutlookMail
      .To = "campboss@suisca.com"
      .CC = ""
      .BCC = ""
      .Subject = "Weekly Order Note"
      .Body = "Good Day to All, Please find Attached order sheet for the week. Please Acknowledge reciept of the attached document, thank you. Best Regards, Camp Boss"
      .Attachments.Add Application.ActiveWorksheet.FullName '
      .Display

      End With

      End Sub

Resources