save as desktop & save as macro free workbook

K

kelvin_9

Active Member
Joined
Mar 6, 2015
Messages
444
Office Version
  1. 2019
Hello All,

i was thinking how can i save my workbook as macro-free workbook at desktop with the file name along today's date and date format likely MM-DD-YYYY (one is 04-12-2022 home delivery and the other one is 04-12-2022 limited delivery)
ps1. i save the workbook once a day, so the name for next day need to be 04-13-2022 home delivery and 04-13-2022 limited delivery
ps2. i guess the code need to be added under "delete object and move" and above "clear data in sheet3 if any"

thank you very much

my code here

VBA Code: 
Option Explicit
Sub Macro1()
'
'
'

'

'NORMAL HOME

Dim WS_1 As Worksheet
    Set WS_1 = Sheets("Sheet1")
Dim WS_2 As Worksheet
    Set WS_2 = Sheets("Sheet2")
Dim WS_3 As Worksheet
    Set WS_3 = Sheets("Sheet3")
Dim Lr As Long

    'filter store and location
    WS_1.Activate
    WS_1.Rows("1:1").AutoFilter
    WS_1.Range("$A$1:$V$1").AutoFilter Field:=2, Criteria1:="NORMAL"
    WS_1.Range("$A$1:$V$1").AutoFilter Field:=10, Criteria1:="="
    Cells.Copy
    WS_2.Activate
    WS_2.Paste

    'back to worksheet 1
    WS_1.Activate
    WS_1.Range("A1").AutoFilter

    'copy order id
    WS_2.Activate
    WS_2.Range("A2", Range("A2").End(xlDown)).Copy
    WS_3.Activate
    WS_3.Range("F2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

   'Find last row in column F with data
    Lr = Cells(Rows.Count, "F").End(xlUp).Row
    WS_3.Range("B2:B" & Lr).FormulaR1C1 = "=RC[-1]+2"
    WS_3.Range("D2:D" & Lr).Value = "123456"
    WS_3.Range("E2:E" & Lr).Value = "ABC"
    WS_3.Range("G2:G" & Lr).FormulaR1C1 = "=CONCATENATE(Sheet2!RC[13],"" "",Sheet2!RC[12])"

    'fill address
    WS_2.Activate
    WS_2.Range("V2:W1000").Copy
    WS_3.Activate
    WS_3.Range("H2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    WS_2.Activate
    WS_2.Range("Y2:Y1000").Copy
    WS_3.Activate
    WS_3.Range("K2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    'fill phone
    WS_2.Activate
    WS_2.Range("U2:U1000").Copy
    WS_3.Activate
    WS_3.Range("L2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    WS_2.Activate
    WS_2.Range("I2:I1000").Copy
    WS_3.Activate
    WS_3.Range("M2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    WS_3.Range("N2:N" & Lr).FormulaR1C1 = "=CONCATENATE(""ORDER ID #"","""",RC[-8])"
    WS_3.Range("Q2:Q" & Lr).Value = "box"
    WS_3.Range("R2:R" & Lr).Value = "1"
    WS_3.Range("S2:S" & Lr).Value = "3"

    'fill date
    If Lr > 2 Then
    WS_3.Range("A3:A" & Lr).Value = WS_3.Range("A2").Value
    End If

    'value
    WS_3.Cells.Copy
    WS_3.Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

    'clear data in sheet2 if any
    WS_2.Activate
    WS_2.Cells.Delete Shift:=xlUp
    WS_2.Range("A1").Select
    WS_1.Activate
    WS_1.Cells.Select
    WS_1.Cells.EntireColumn.AutoFit
    WS_1.Range("A1").Select

    'delete object and move
    WS_3.Activate
    WS_3.Copy
    Sheets("Sheet3").Name = "normal home"
    ActiveSheet.DrawingObjects.Select
    Selection.Delete

    'clear data in sheet3 if any
    WS_3.Rows("2:1000").Delete
    With WS_3.Range("A2").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.499984740745262
        .PatternTintAndShade = 0
    End With

End Sub
Sub Macro2()
'
'
'

'

'LIMITED HOME

Dim WS_1 As Worksheet
    Set WS_1 = Sheets("Sheet1")
Dim WS_2 As Worksheet
    Set WS_2 = Sheets("Sheet2")
Dim WS_3 As Worksheet
    Set WS_3 = Sheets("Sheet3")
Dim Lr As Long

    'filter store and location
    WS_1.Activate
    WS_1.Rows("1:1").AutoFilter
    WS_1.Range("$A$1:$V$1").AutoFilter Field:=2, Criteria1:="limited"
    WS_1.Range("$A$1:$V$1").AutoFilter Field:=10, Criteria1:="="
    Cells.Copy
    WS_2.Activate
    WS_2.Paste

    'back to worksheet 1
    WS_1.Activate
    WS_1.Range("A1").AutoFilter
    'copy order id
    WS_2.Activate
    WS_2.Range("A2", Range("A2").End(xlDown)).Copy
    WS_3.Activate
    WS_3.Range("F2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

   'Find last row in column F with data
    Lr = Cells(Rows.Count, "F").End(xlUp).Row
    WS_3.Range("B2:B" & Lr).FormulaR1C1 = "=RC[-1]+2"
    WS_3.Range("D2:D" & Lr).Value = "123456"
    WS_3.Range("E2:E" & Lr).Value = "ABC"
    WS_3.Range("G2:G" & Lr).FormulaR1C1 = "=CONCATENATE(Sheet2!RC[13],"" "",Sheet2!RC[12])"
    
    'fill address
    WS_2.Activate
    WS_2.Range("V2:W1000").Copy
    WS_3.Activate
    WS_3.Range("H2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    WS_2.Activate
    WS_2.Range("Y2:Y1000").Copy
    WS_3.Activate
    WS_3.Range("K2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    'fill phone
    WS_2.Activate
    WS_2.Range("U2:U1000").Copy
    WS_3.Activate
    WS_3.Range("L2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    WS_2.Activate
    WS_2.Range("I2:I1000").Copy
    WS_3.Activate
    WS_3.Range("M2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    WS_3.Range("N2:N" & Lr).FormulaR1C1 = "=CONCATENATE(""ORDER ID #"","""",RC[-8])"
    WS_3.Range("Q2:Q" & Lr).Value = "box"
    WS_3.Range("R2:R" & Lr).Value = "1"
    WS_3.Range("S2:S" & Lr).Value = "3"

    'fill date
    If Lr > 2 Then
    WS_3.Range("A3:A" & Lr).Value = WS_3.Range("A2").Value
    End If

    'value
    WS_3.Cells.Copy
    WS_3.Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

    'clear data in sheet2 if any
    WS_2.Activate
    WS_2.Cells.Delete Shift:=xlUp
    WS_2.Range("A1").Select
    WS_1.Activate
    WS_1.Cells.Select
    WS_1.Cells.EntireColumn.AutoFit
    WS_1.Range("A1").Select

    'delete object and move
    WS_3.Activate
    WS_3.Copy
    Sheets("Sheet3").Name = "limited home"
    ActiveSheet.DrawingObjects.Select
    Selection.Delete

    'clear data in sheet3 if any
    WS_3.Rows("2:1000").Delete
    With WS_3.Range("A2").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.499984740745262
        .PatternTintAndShade = 0
    End With

End Sub
 

Excel Facts

Is there a shortcut key for strikethrough?
Ctrl+S is used for Save. Ctrl+5 is used for Strikethrough. Why Ctrl+5? When you use hashmarks to count |||| is 4, strike through to mean 5.
Sort by date Sort by votes
kelvin_9 said:
i was thinking how can i save my workbook as macro-free workbook at desktop with the file name along today's date and date format likely MM-DD-YYYY (one is 04-12-2022 home delivery and the other one is 04-12-2022 limited delivery)
Click to expand...
Add this code to the module:
VBA Code: 
Private Sub Save_Workbook_As_xlsx(wb As Workbook, file As String)

    Dim tempFile As String
    Dim tempWorkbook As Workbook
    Dim p As Long
    
    'Create a temporary copy of the .xlsm/.xlsb workbook
    
    With wb
        p = InStrRev(.FullName, ".")
        tempFile = Left(.FullName, p - 1) & " TEMP COPY" & Mid(.FullName, p)
        .SaveCopyAs tempFile
    End With
        
    'Open the temporary copy and save it as a .xlsx file
    
    Set tempWorkbook = Workbooks.Open(tempFile)    
    Application.DisplayAlerts = False
    tempWorkbook.SaveAs file, xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    tempWorkbook.Close False
    
    'Delete the temporary copy
    
    Kill tempFile
    
End Sub
Call it from your macros like this:
VBA Code: 
    Dim DesktopFolder As String
    
    DesktopFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
    Save_Workbook_As_xlsx ThisWorkbook, DesktopFolder & Format(Date, "mm-dd-yyyy") & " home delivery.xlsx"
 
Upvote 0
Solution
John_w said:
Add this code to the module:
VBA Code: 
Private Sub Save_Workbook_As_xlsx(wb As Workbook, file As String)

    Dim tempFile As String
    Dim tempWorkbook As Workbook
    Dim p As Long
   
    'Create a temporary copy of the .xlsm/.xlsb workbook
   
    With wb
        p = InStrRev(.FullName, ".")
        tempFile = Left(.FullName, p - 1) & " TEMP COPY" & Mid(.FullName, p)
        .SaveCopyAs tempFile
    End With
       
    'Open the temporary copy and save it as a .xlsx file
   
    Set tempWorkbook = Workbooks.Open(tempFile)   
    Application.DisplayAlerts = False
    tempWorkbook.SaveAs file, xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    tempWorkbook.Close False
   
    'Delete the temporary copy
   
    Kill tempFile
   
End Sub
Call it from your macros like this:
VBA Code: 
    Dim DesktopFolder As String
   
    DesktopFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
    Save_Workbook_As_xlsx ThisWorkbook, DesktopFolder & Format(Date, "mm-dd-yyyy") & " home delivery.xlsx"
Click to expand...
Hi John_w
thank you very much for your reply

i'm sorry i'm not very understand the second code where should i place this correctly
i have module1 with macro1 and macro2
i used comobox to run this 2 macro

now i have this in module1
VBA Code: 
Option Explicit
Sub Macro1()
'
'
'

'

'NORMAL HOME

Dim WS_1 As Worksheet
    Set WS_1 = Sheets("Sheet1")
Dim WS_2 As Worksheet
    Set WS_2 = Sheets("Sheet2")
Dim WS_3 As Worksheet
    Set WS_3 = Sheets("Sheet3")
Dim Lr As Long

    'filter store and location
    WS_1.Activate
    WS_1.Rows("1:1").AutoFilter
    WS_1.Range("$A$1:$V$1").AutoFilter Field:=2, Criteria1:="NORMAL"
    WS_1.Range("$A$1:$V$1").AutoFilter Field:=10, Criteria1:="="
    Cells.Copy
    WS_2.Activate
    WS_2.Paste

    'back to worksheet 1
    WS_1.Activate
    WS_1.Range("A1").AutoFilter

    'copy order id
    WS_2.Activate
    WS_2.Range("A2", Range("A2").End(xlDown)).Copy
    WS_3.Activate
    WS_3.Range("F2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

   'Find last row in column F with data
    Lr = Cells(Rows.Count, "F").End(xlUp).Row
    WS_3.Range("B2:B" & Lr).FormulaR1C1 = "=RC[-1]+2"
    WS_3.Range("D2:D" & Lr).Value = "9714350"
    WS_3.Range("E2:E" & Lr).Value = "Hong Kong Disneyland"
    WS_3.Range("G2:G" & Lr).FormulaR1C1 = "=CONCATENATE(Sheet2!RC[13],"" "",Sheet2!RC[12])"

    'fill address
    WS_2.Activate
    WS_2.Range("V2:W1000").Copy
    WS_3.Activate
    WS_3.Range("H2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    WS_2.Activate
    WS_2.Range("Y2:Y1000").Copy
    WS_3.Activate
    WS_3.Range("K2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    'fill phone
    WS_2.Activate
    WS_2.Range("U2:U1000").Copy
    WS_3.Activate
    WS_3.Range("L2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    WS_2.Activate
    WS_2.Range("I2:I1000").Copy
    WS_3.Activate
    WS_3.Range("M2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    WS_3.Range("N2:N" & Lr).FormulaR1C1 = "=CONCATENATE(""ORDER ID #"","""",RC[-8])"
    WS_3.Range("Q2:Q" & Lr).Value = "box"
    WS_3.Range("R2:R" & Lr).Value = "1"
    WS_3.Range("S2:S" & Lr).Value = "3"

    'fill date
    If Lr > 2 Then
    WS_3.Range("A3:A" & Lr).Value = WS_3.Range("A2").Value
    End If

    'value
    WS_3.Cells.Copy
    WS_3.Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

    'clear data in sheet2 if any
    WS_2.Activate
    WS_2.Cells.Delete Shift:=xlUp
    WS_2.Range("A1").Select
    WS_1.Activate
    WS_1.Cells.Select
    WS_1.Cells.EntireColumn.AutoFit
    WS_1.Range("A1").Select

    'delete object and move
    WS_3.Activate
    WS_3.Copy
    Sheets("Sheet3").Name = "normal home"
    ActiveSheet.DrawingObjects.Select
    Selection.Delete

    'clear data in sheet3 if any
    WS_3.Rows("2:1000").Delete
    With WS_3.Range("A2").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.499984740745262
        .PatternTintAndShade = 0
    End With

End Sub
Sub Macro2()
'
'
'

'

'LIMITED HOME

Dim WS_1 As Worksheet
    Set WS_1 = Sheets("Sheet1")
Dim WS_2 As Worksheet
    Set WS_2 = Sheets("Sheet2")
Dim WS_3 As Worksheet
    Set WS_3 = Sheets("Sheet3")
Dim Lr As Long

    'filter store and location
    WS_1.Activate
    WS_1.Rows("1:1").AutoFilter
    WS_1.Range("$A$1:$V$1").AutoFilter Field:=2, Criteria1:="limited"
    WS_1.Range("$A$1:$V$1").AutoFilter Field:=10, Criteria1:="="
    Cells.Copy
    WS_2.Activate
    WS_2.Paste

    'back to worksheet 1
    WS_1.Activate
    WS_1.Range("A1").AutoFilter
    'copy order id
    WS_2.Activate
    WS_2.Range("A2", Range("A2").End(xlDown)).Copy
    WS_3.Activate
    WS_3.Range("F2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

   'Find last row in column F with data
    Lr = Cells(Rows.Count, "F").End(xlUp).Row
    WS_3.Range("B2:B" & Lr).FormulaR1C1 = "=RC[-1]+2"
    WS_3.Range("D2:D" & Lr).Value = "9714350"
    WS_3.Range("E2:E" & Lr).Value = "Hong Kong Disneyland"
    WS_3.Range("G2:G" & Lr).FormulaR1C1 = "=CONCATENATE(Sheet2!RC[13],"" "",Sheet2!RC[12])"
    
    'fill address
    WS_2.Activate
    WS_2.Range("V2:W1000").Copy
    WS_3.Activate
    WS_3.Range("H2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    WS_2.Activate
    WS_2.Range("Y2:Y1000").Copy
    WS_3.Activate
    WS_3.Range("K2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    'fill phone
    WS_2.Activate
    WS_2.Range("U2:U1000").Copy
    WS_3.Activate
    WS_3.Range("L2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    WS_2.Activate
    WS_2.Range("I2:I1000").Copy
    WS_3.Activate
    WS_3.Range("M2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    WS_3.Range("N2:N" & Lr).FormulaR1C1 = "=CONCATENATE(""ORDER ID #"","""",RC[-8])"
    WS_3.Range("Q2:Q" & Lr).Value = "box"
    WS_3.Range("R2:R" & Lr).Value = "1"
    WS_3.Range("S2:S" & Lr).Value = "3"

    'fill date
    If Lr > 2 Then
    WS_3.Range("A3:A" & Lr).Value = WS_3.Range("A2").Value
    End If

    'value
    WS_3.Cells.Copy
    WS_3.Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

    'clear data in sheet2 if any
    WS_2.Activate
    WS_2.Cells.Delete Shift:=xlUp
    WS_2.Range("A1").Select
    WS_1.Activate
    WS_1.Cells.Select
    WS_1.Cells.EntireColumn.AutoFit
    WS_1.Range("A1").Select

    'delete object and move
    WS_3.Activate
    WS_3.Copy
    Sheets("Sheet3").Name = "limited home"
    ActiveSheet.DrawingObjects.Select
    Selection.Delete

    'clear data in sheet3 if any
    WS_3.Rows("2:1000").Delete
    With WS_3.Range("A2").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.499984740745262
        .PatternTintAndShade = 0
    End With

End Sub
Private Sub Save_Workbook_As_xlsx(wb As Workbook, file As String)

    Dim tempFile As String
    Dim tempWorkbook As Workbook
    Dim p As Long
    
    'Create a temporary copy of the .xlsm/.xlsb workbook
    
    With wb
        p = InStrRev(.FullName, ".")
        tempFile = Left(.FullName, p - 1) & " TEMP COPY" & Mid(.FullName, p)
        .SaveCopyAs tempFile
    End With
        
    'Open the temporary copy and save it as a .xlsx file
    
    Set tempWorkbook = Workbooks.Open(tempFile)
    Application.DisplayAlerts = False
    tempWorkbook.SaveAs file, xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    tempWorkbook.Close False
    
    'Delete the temporary copy
    
    Kill tempFile
    
End Sub
    Dim DesktopFolder As String
    
    DesktopFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
    Save_Workbook_As_xlsx ThisWorkbook, DesktopFolder & Format(Date, "mm-dd-yyyy") & " home delivery.xlsx"

my workbook here if it is necessary
TEST 1.xlsm
 
Upvote 0
I haven't looked at your workbook.

kelvin_9 said:
ps2. i guess the code need to be added under "delete object and move" and above "clear data in sheet3 if any"
Click to expand...
In Macro1 replace:
VBA Code: 
    'delete object and move
    WS_3.Activate
    WS_3.Copy
    Sheets("Sheet3").Name = "normal home"
    ActiveSheet.DrawingObjects.Select
    Selection.Delete
with:
VBA Code: 
    'delete object and move
    WS_3.Activate
    WS_3.Copy
    Sheets("Sheet3").Name = "normal home"
    ActiveSheet.DrawingObjects.Select
    Selection.Delete

    Dim DesktopFolder As String    
    DesktopFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
    Save_Workbook_As_xlsx ThisWorkbook, DesktopFolder & Format(Date, "mm-dd-yyyy") & " home delivery.xlsx"
In Macro2 replace:
VBA Code: 
    'delete object and move
    WS_3.Activate
    WS_3.Copy
    Sheets("Sheet3").Name = "limited home"
    ActiveSheet.DrawingObjects.Select
    Selection.Delete
with:
VBA Code: 
    'delete object and move
    WS_3.Activate
    WS_3.Copy
    Sheets("Sheet3").Name = "limited home"
    ActiveSheet.DrawingObjects.Select
    Selection.Delete

    Dim DesktopFolder As String    
    DesktopFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
    Save_Workbook_As_xlsx ThisWorkbook, DesktopFolder & Format(Date, "mm-dd-yyyy") & " limited delivery.xlsx"
 
Upvote 0
John_w said:
I haven't looked at your workbook.


In Macro1 replace:
VBA Code: 
    'delete object and move
    WS_3.Activate
    WS_3.Copy
    Sheets("Sheet3").Name = "normal home"
    ActiveSheet.DrawingObjects.Select
    Selection.Delete
with:
VBA Code: 
    'delete object and move
    WS_3.Activate
    WS_3.Copy
    Sheets("Sheet3").Name = "normal home"
    ActiveSheet.DrawingObjects.Select
    Selection.Delete

    Dim DesktopFolder As String  
    DesktopFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
    Save_Workbook_As_xlsx ThisWorkbook, DesktopFolder & Format(Date, "mm-dd-yyyy") & " home delivery.xlsx"
In Macro2 replace:
VBA Code: 
    'delete object and move
    WS_3.Activate
    WS_3.Copy
    Sheets("Sheet3").Name = "limited home"
    ActiveSheet.DrawingObjects.Select
    Selection.Delete
with:
VBA Code: 
    'delete object and move
    WS_3.Activate
    WS_3.Copy
    Sheets("Sheet3").Name = "limited home"
    ActiveSheet.DrawingObjects.Select
    Selection.Delete

    Dim DesktopFolder As String  
    DesktopFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
    Save_Workbook_As_xlsx ThisWorkbook, DesktopFolder & Format(Date, "mm-dd-yyyy") & " limited delivery.xlsx"
Click to expand...
Hi John_w
thank you very much for your reply

i got you now and it's working just prefect unless, my workbook has 3 sheets but i just want sheet_3 move or copy, can i ?
this seems saving as a new workbook with all 3 sheets, the button and the name i wanted

thank you very much
 
Upvote 0
You said you wanted to save the workbook, i.e. all sheets. To save only a specific sheet, in this case the one renamed "normal home" in the following code:

VBA Code: 
    'delete object and move
    WS_3.Activate
    WS_3.Copy
    Sheets("Sheet3").Name = "normal home"
    ActiveSheet.DrawingObjects.Select
    Selection.Delete
Insert the following code immediately below it:
VBA Code: 
    Dim DesktopFolder As String    
    DesktopFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"

    Worksheets("normal home").Copy
    ActiveWorkbook.SaveCopyAs DesktopFolder & Format(Date, "mm-dd-yyyy") & " home delivery.xlsx"
    ActiveWorkbook.Close SaveChanges:=False
Do the same for the other macro, changing the sheet name and file name as appropriate.
 
Upvote 0
John_w said:
You said you wanted to save the workbook, i.e. all sheets. To save only a specific sheet, in this case the one renamed "normal home" in the following code:

VBA Code: 
    'delete object and move
    WS_3.Activate
    WS_3.Copy
    Sheets("Sheet3").Name = "normal home"
    ActiveSheet.DrawingObjects.Select
    Selection.Delete
Insert the following code immediately below it:
VBA Code: 
    Dim DesktopFolder As String  
    DesktopFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"

    Worksheets("normal home").Copy
    ActiveWorkbook.SaveCopyAs DesktopFolder & Format(Date, "mm-dd-yyyy") & " home delivery.xlsx"
    ActiveWorkbook.Close SaveChanges:=False
Do the same for the other macro, changing the sheet name and file name as appropriate.
Click to expand...
Hi John_w
thank you very much for your reply

ugh... the object(the button) still in the workbook i save as desktop?

thank you very much
 
Upvote 0
John_w said:
You said you wanted to save the workbook, i.e. all sheets. To save only a specific sheet, in this case the one renamed "normal home" in the following code:

VBA Code: 
    'delete object and move
    WS_3.Activate
    WS_3.Copy
    Sheets("Sheet3").Name = "normal home"
    ActiveSheet.DrawingObjects.Select
    Selection.Delete
Insert the following code immediately below it:
VBA Code: 
    Dim DesktopFolder As String   
    DesktopFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"

    Worksheets("normal home").Copy
    ActiveWorkbook.SaveCopyAs DesktopFolder & Format(Date, "mm-dd-yyyy") & " home delivery.xlsx"
    ActiveWorkbook.Close SaveChanges:=False
Do the same for the other macro, changing the sheet name and file name as appropriate.
Click to expand...
Hi John_w
updated as below

i feel so sorry and appreciated if i can ask again
i want to save only sheet3 as new workbook with no object(command button) and save as date & home delivery

i used your code below but i found the object also deleted in the original workbook
VBA Code: 
    'delete object and move
    WS_3.Activate
    Sheets("Sheet3").Name = "normal home"
    ActiveSheet.DrawingObjects.Select
    Selection.Delete

    Dim DesktopFolder As String
    DesktopFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"

    Worksheets("normal home").Copy
    ActiveWorkbook.SaveCopyAs DesktopFolder & Format(Date, "mm-dd-yyyy") & " home delivery.xlsx"
    ActiveWorkbook.Close SaveChanges:=False

    WS_3.Activate
    Sheets("normal home").Name = "Sheet3"
 
Upvote 0
I really can't help further without your workbook, however it requires a password to open it.
 
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Question
VBA Speed up Copy and paste
Replies
3
Views
409
skillilea
S
willow1985
  • Solved
Find first blank cell in column A in a Table - Runtime error 91
Replies
4
Views
138
willow1985
willow1985
D
  • Question
VBA optimization advice
Replies
3
Views
148
bobsan42
bobsan42
excelbytes
  • Solved
VBA Code To Copy Data Into Next Blank Column
Replies
5
Views
148
mumps
mumps
J
  • Question
VBA to select partial filename and go back and forth between two files to copy paste
Replies
1
Views
195
shknbk2
S

Forum statistics

Threads
1,215,592
Messages
6,125,713
Members
449,253
Latest member
Mbogo

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top