Macro help

[Jemma Atkinson]

Hi, i have the below code which creates folders if they do not exist and then copies worksheets to a new workbook. I need to adjust this code, i require to resave active workbook as Summary dd-mm-yy and delete all sheets apart from these.

([{"Workings","Test1","Test2"}]).

Sub test1()
Dim myName As String, myFolder As String, e
Dim fso As Object, temp As String
Application.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")
myFolder = "C:\Users\Jemma\Documents\Jemma\VBA & Excel\" & Year(Date) & "\" & Format$(Date, "mmm") _
            & "\Client_Copies"
For Each e In Split(myFolder, "\")
    temp = temp & IIf(temp = "", "", "\") & e
    If fso.FolderExists(temp) = False Then fso.CreateFolder (temp)
Next
myName = Format$(Date, "mmddyy") & "_Copy" & ThisWorkbook.Name
With Workbooks.Add
    ThisWorkbook.Sheets([{"Workings","Test1","Test2"}]).Copy _
    before:=.Sheets(1)
    .SaveAs myFolder & "\" & myName
End With
Application.ScreenUpdating = True
End Sub

 

[Jemma Atkinson]

*bump*

 

[Jemma Atkinson]

*bump*

 

[Mark F]

Jemma

I take it to mean that you would be really grateful if someone could give up their time to help you in solving your problem

Maybe this will work?

Sub test1()
Dim myName As String, myFolder As String, e
Dim fso As Object, temp As String
Application.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")
myFolder = "C:\Users\Jemma\Documents\Jemma\VBA & Excel\" & Year(Date) & "\" & Format$(Date, "mmm") _
            & "\Client_Copies"
For Each e In Split(myFolder, "\")
    temp = temp & IIf(temp = "", "", "\") & e
    If fso.FolderExists(temp) = False Then fso.CreateFolder (temp)
Next
myName = "Summary" & Format$(Date, "mmddyy") 
With Workbooks.Add
    ThisWorkbook.Sheets([{"Workings","Test1","Test2"}]).Copy _
    before:=.Sheets(1)
    .SaveAs myFolder & "\" & myName
End With
Application.ScreenUpdating = True
End Sub

Mark

 

[Jemma Atkinson]

Hey Mark, thats it, and I would be very grateful if you can help me

ok i tried the below, but it still creates a new workbook and copies the sheets across rather than saving over the active workbook and deleting all sheets except for those 3 mentioned.

Jemma

I take it to mean that you would be really grateful if someone could give up their time to help you in solving your problem

Maybe this will work?

Sub test1()
Dim myName As String, myFolder As String, e
Dim fso As Object, temp As String
Application.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")
myFolder = "C:\Users\Jemma\Documents\Jemma\VBA & Excel\" & Year(Date) & "\" & Format$(Date, "mmm") _
            & "\Client_Copies"
For Each e In Split(myFolder, "\")
    temp = temp & IIf(temp = "", "", "\") & e
    If fso.FolderExists(temp) = False Then fso.CreateFolder (temp)
Next
myName = "Summary" & Format$(Date, "mmddyy") 
With Workbooks.Add
    ThisWorkbook.Sheets([{"Workings","Test1","Test2"}]).Copy _
    before:=.Sheets(1)
    .SaveAs myFolder & "\" & myName
End With
Application.ScreenUpdating = True
End Sub

Mark

 

[Legacy 68668]

What do you mean by "active workbook " ?

 

[Legacy 68668]

Do you mean like this ?

Sub test1()
Dim myName As String, myFolder As String, e
Dim fso As Object, temp As String
Application.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")
myFolder = "C:\Users\Jemma\Documents\Jemma\VBA & Excel\" & Year(Date) & "\" & Format$(Date, "mmm") _
            & "\Client_Copies"
For Each e In Split(myFolder, "\")
    temp = temp & IIf(temp = "", "", "\") & e
    If fso.FolderExists(temp) = False Then fso.CreateFolder (temp)
Next
myName = "Summary " &  Format(Date, "ddmmyy") & ".xls"
ThisWorkbook.Sheets([{"Workings","Test1","Test2"}]).Copy
ActiveWorkbook.SaveAs myFolder & "\" & myName
Application.ScreenUpdating = True
End Sub

 

[Jemma Atkinson]

Seiya, i need to resave over the active workbook which is this workbook i am running this macro from as i need to keep this macros when file is resaved.

Do you mean like this ?

Sub test1()
Dim myName As String, myFolder As String, e
Dim fso As Object, temp As String
Application.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")
myFolder = "C:\Users\Jemma\Documents\Jemma\VBA & Excel\" & Year(Date) & "\" & Format$(Date, "mmm") _
            & "\Client_Copies"
For Each e In Split(myFolder, "\")
    temp = temp & IIf(temp = "", "", "\") & e
    If fso.FolderExists(temp) = False Then fso.CreateFolder (temp)
Next
myName = "Summary " &  Format(Date, "ddmmyy") & ".xls"
ThisWorkbook.Sheets([{"Workings","Test1","Test2"}]).Copy
ActiveWorkbook.SaveAs myFolder & "\" & myName
Application.ScreenUpdating = True
End Sub

 

[Legacy 68668]

....

 

[Legacy 68668]

Sub test1()
Dim myName As String, myFolder As String, e
Dim fso As Object, temp As String
Application.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")
myFolder = "C:\Users\Jemma\Documents\Jemma\VBA & Excel\" & Year(Date) & "\" & Format$(Date, "mmm") _
            & "\Client_Copies"
For Each e In Split(myFolder, "\")
    temp = temp & IIf(temp = "", "", "\") & e
    If fso.FolderExists(temp) = False Then fso.CreateFolder (temp)
Next
myName = "Summary " & Format$(Date, "mmddyy") & ".xls"
Application.DisplayAlerts = False
With ThisWorkbook
    For Each ws In .Sheets
        Select Case ws.Name
            Case "Workings","Test1","Test2"
            Case Else: ws.Delete
        End Select
    Next
    Application.DisplayAlerts = True
    .SaveAs myFolder & "\" & myName
End With
Application.ScreenUpdating = True
End Sub