Need assistance in cleaning up a macro

[ghrek]

Hi

I have the following macro and I need to tidy up and make a few changes if poss. What it is when it opens up X/BACKUP I need it to auto create a subfolder and then ask me to name it before moving the data from the other files into it.

Macro enclosed.

ActiveWorkbook.SaveAs fileName:="X:\backup\summary.xls", FileFormat:= _
xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
ChDir "X:\NEW INPUT SCREENS"
Workbooks.Open fileName:="X:\NEW INPUT SCREENS\WEEK 1.xls"
ActiveWorkbook.Save
ChDir "X:\backup"
ActiveWorkbook.SaveAs fileName:="X:\backup\WEEK 1.xls", FileFormat:= _
xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
ChDir "X:\MKEYNES"
Workbooks.Open fileName:="X:\MKEYNES\WEEK 2.XLS", updatelinks:=3
ChDir "X:\backup"
ActiveWorkbook.SaveAs fileName:="X:\backup\WEEK 2.xls", FileFormat:= _
xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
ChDir "X:\NEW INPUT SCREENS"
Workbooks.Open fileName:="X:\NEW INPUT SCREENS\WEEK 3.xls"
ChDir "X:\backup"
ActiveWorkbook.SaveAs fileName:="X:\backup\WEEK 3.xls", FileFormat:= _
xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
ChDir "X:\MKEYNES"
Workbooks.Open fileName:="X:\MKEYNES\WEEK 4.XLS", updatelinks:=0
ChDir "X:\backup"
ActiveWorkbook.SaveAs fileName:="X:\backup\WEEK 4.xls", FileFormat:= _
xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
ActiveWindow.Close
ActiveWindow.Close
ActiveWindow.Close
ActiveWindow.Close
End Sub

 

[ghrek]

Sorry for delay.

Yes I do mean what you said on your comment.

 

[DanteAmor]

I guess you have to do it for every page of every book?

 

[ghrek]

unfortunally yes I have to .

Would this work??

Sub test()
Dim sName As Variant, bFolder As String, dest As String

sName = InputBox("Subfolder name")
If sName = "" Then Exit Sub

bFolder = "X:\backup"


If Dir(bFolder & "" & sName, vbDirectory) = "" Then
MkDir bFolder & "" & sName
End If
dest = bFolder & "" & sName & ""

ActiveWorkbook.Sheets.Copy

End Sub

 

[DanteAmor]

Try this

Sub test()
    Dim sName As Variant, bFolder As String, dest As String
    Dim wb2 As Workbook, sh As Worksheet, j As Long, wFiles as variant
    
    sName = InputBox("Subfolder name")
    If sName = "" Then Exit Sub
    
    bFolder = "X:\backup"
    
    If Dir(bFolder & "\" & sName, vbDirectory) = "" Then
        MkDir bFolder & "\" & sName
    End If
    dest = bFolder & "\" & sName & "\"
    
    wFiles = Array("WEEK 1.xls", "WEEK 2.xls", "WEEK 3.xls", "WEEK 4.xls")
    
    FileCopy "X:\NEW INPUT SCREENS\WEEK 1.xls", dest & "WEEK 1.xls"
    FileCopy "X:\MKEYNES\WEEK 2.XLS", dest & "WEEK 2.xls"
    FileCopy "X:\NEW INPUT SCREENS\WEEK 3.xls", dest & "WEEK 3.xls"
    FileCopy "X:\MKEYNES\WEEK 4.XLS", dest & "WEEK 4.xls"
    
    For j = 0 To UBound(wFiles)
    
        Set wb2 = Workbooks.Open(dest & wFiles(j))
        For Each sh In wb2.Sheets
            sh.Cells.Copy
            sh.Range("A1").PasteSpecial xlPasteValues
        Next
        wb2.Close True
    Next
    MsgBox "Done"
End Sub