save as desktop & save as macro free workbook

K

kelvin_9

Active Member
Joined
Mar 6, 2015
Messages
460
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

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type
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

D
  • Solved
extract to another workbook and save using desktop path
2
Replies
12
Views
208
jolivanes
jolivanes
willow1985
  • Solved
VBA Run-time error 91 - Object variable or With block variable not set when trying to refresh data/Sleep
Replies
4
Views
398
willow1985
willow1985
A
  • Question Question
Need advise on code
2
Replies
11
Views
176
AlexanderBB
A
T
  • Solved
Left of character
Replies
8
Views
135
Peter_SSs
Peter_SSs
F
  • Solved
How to make loop stop when the cell is empty? (VBA)
Replies
3
Views
298
kvsrinivasamurthy
K

Forum statistics

Threads
1,224,749
Messages
6,180,725
Members
452,995
Latest member
isldboy

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