Καλημέρα!
Συμφωνώ με την προσέγγιση του Θανάση:045:
Με τον τρόπο αυτό, το κελί A1 που θα περιέχει το όνομα που θα δοθεί στο αρχείο θα πρέπει βρίσκεται απαραίτητα στο ενεργό φύλλο κατά την εκτέλεση του κώδικα.
Έστω ότι το όνομα που θα πάρει το βιβλίο εργασίας μέσω του κώδικα βρίσκεται στο Φύλλο1 και στο κελί A1.
Αν πχ. το τρέχον φύλλο είναι το Φύλλο2, η τιμή που θα λάβει υπόψη του ο κώδικας θα είναι αυτή του κελιού Α1 του τρέχοντος φύλλου δηλ. του φύλου2 και όχι αυτή που έχουμε ορίσει στο φύλλο1.
Θα πρότεινα να οριστούν ονόματα που θα ζητούνται από τον κώδικα.
Επίσης, για να αποκτήσει περισσότερη ελαστικότητα η όλη διαδικασία , μπορούμε: - να παραμετροποιήσουμε το όνομα του αρχείου προς αντιγραφή.
- να παραμετροποιήσουμε τη διαδρομή φακέλου όπου θα βρίσκεται.
- να παραμετροποιήσουμε το όνομα του φύλλου προς αντιγραφή.
- να παραμετροποιήσουμε την περιοχή που του φύλλου που θα αντιγραφεί.
Παραδειγματικά, ορίζουμε τα παρακάτω ονόματα: - 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
Φιλικά
Τάσος | 