[Tasos]

Καλημέρα!
Συμφωνώ με την προσέγγιση του Θανάση
Με τον τρόπο αυτό, το κελί A1 που θα περιέχει το όνομα που θα δοθεί στο αρχείο θα πρέπει βρίσκεται απαραίτητα στο ενεργό φύλλο κατά την εκτέλεση του κώδικα.

Έστω ότι το όνομα που θα πάρει το βιβλίο εργασίας μέσω του κώδικα βρίσκεται στο Φύλλο1 και στο κελί A1.
Αν πχ. το τρέχον φύλλο είναι το Φύλλο2, η τιμή που θα λάβει υπόψη του ο κώδικας θα είναι αυτή του κελιού Α1 του τρέχοντος φύλλου δηλ. του φύλου2 και όχι αυτή που έχουμε ορίσει στο φύλλο1.
Θα πρότεινα να οριστούν ονόματα που θα ζητούνται από τον κώδικα.
Επίσης, για να αποκτήσει περισσότερη ελαστικότητα η όλη διαδικασία , μπορούμε:

1. να παραμετροποιήσουμε το όνομα του αρχείου προς αντιγραφή.
2. να παραμετροποιήσουμε τη διαδρομή φακέλου όπου θα βρίσκεται.
3. να παραμετροποιήσουμε το όνομα του φύλλου προς αντιγραφή.
4. να παραμετροποιήσουμε την περιοχή που του φύλλου που θα αντιγραφεί.

Παραδειγματικά, ορίζουμε τα παρακάτω ονόματα:

• WorkBookName = το όνομα του αρχείου προς αντιγραφή.
• SheetToTransfer = το όνομα του φύλλου προς αντιγραφή.
• File_Path = η διαδρομή φακέλου όπου θα αποθηκεύεται το αρχείο.
• MyRange = η περιοχή που του φύλλου που θα αντιγραφεί.

Στα κελιά που αντιστοιχούν στα παραπάνω ονόματα περνάμε τις τιμές όπως παρακάτω:

• WorkBookName = Αρχείο.xls
• SheetToTransfer = Φύλλο2
• File_Path = C:\Mytest
• MyRange =A1:H100 (αν μείνει κενό, ο κώδικας θα πάρει την χρησιμοποιημένη περιοχή του Φύλλου2).

και χρησιμοποιούμε τον παρακάτω κώδικα,

Option Explicit

Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long

Sub CreateClearBook()
    Dim wbNewBook As Workbook
    Dim Sheets_InNewBook%, Calc&
    Dim wbName$, WKSToCopy$, strFilePath$, WKSRange As Range
    On Error Resume Next
    wbName = Range("WorkBookName")
    WKSToCopy = Range("SheetToTransfer")
    If Trim(Range("MyRange")) <> vbNullString Then
        Set WKSRange = Sheets(WKSToCopy).Range(Range("MyRange"))
    End If
    If WKSRange Is Nothing Then
        Set WKSRange = Sheets(WKSToCopy).UsedRange
    End If
    strFilePath = Range("File_Path")
    Calc = Application.Calculation
    With Application
        .ScreenUpdating = False
        Sheets_InNewBook = .SheetsInNewWorkbook
        .SheetsInNewWorkbook = 1
        If Calc <> xlCalculationManual Then .Calculation = xlCalculationManual
    End With
    On Error GoTo ErrHandler
    WKSRange.Copy
    Set wbNewBook = Workbooks.Add
    Range("A1").PasteSpecial (xlPasteAll)
    Range("A1").PasteSpecial (xlPasteColumnWidths)
    wbNewBook.SaveAs NextFreeName(strFilePath, wbName), ThisWorkbook.FileFormat
    ExitHere:
    On Error Resume Next
    wbNewBook.Close False
    With Application
        .SheetsInNewWorkbook = Sheets_InNewBook
        If .Calculation <> Calc Then .Calculation = Calc
    End With
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "Error: " & Err
    Resume ExitHere
End Sub

Function NextFreeName(strPath$, strFile$) As String
    Dim strEnum%, sFile$
    strPath = Replace(strPath & "\", "\\", "\")
    MakeSureDirectoryPathExists strPath
    sFile = Dir(strPath & "*" & strFile, vbNormal)
    Do Until sFile = ""
        strEnum = Application.Max(strEnum, IIf(IsNumeric(Left(sFile, 3)), Left(sFile, 3), 0))
        sFile = Dir
    Loop
    NextFreeName = strPath & IIf(strEnum = 0, "001_", _
                                 Format(strEnum + 1, "000_")) & strFile
End Function

Φιλικά

Τάσος