Çalışma sayfasını kitap olarak kaydetme

mbldn · 28 Nisan 2011

Sayın hocalarım sevgili arkadaşlar;
aşağıdaki kod ile sayfayı kitap olarak kaydedebiliyorum. fakat bazı bilgisayarlarda d ya da c sürücüsü yok ya da bu sürücülere kayıt yapmak admin tarafından kısıtlanmış durumda bu durumda kod çalışmayacaktır. nasıl bu kodu revize etmeliyim ki kaydet butonuna basıldığında bana nereye kaydedeceğimi ve haçalışma kitabının hangi sayfasını kaydedeceğimi sorsun
saygılarımla

Kod:

Private Sub CommandButton4_Click()
Application.ScreenUpdating = False

Dim deger As String, Component As Object, VBComponents As Object, kaynak As String, Modul As Object
 
    Application.ScreenUpdating = False
    kaynak = "c:\Siparişler"
        If Not CreateObject("Scripting.FileSystemObject").FolderExists(kaynak) Then
        CreateObject("Scripting.FileSystemObject").CreateFolder (kaynak)
    End If
    If Worksheets("Sipariş").Range("B6") = "" Then
        MsgBox "Kayıt Yapılacak Veri Bulunamadı.", vbInformation, " BİLGİ"
    Else
        
        Sheets("Sipariş").Copy
        For Each Component In ActiveWorkbook.VBProject.VBComponents
            If Component.Type <> 100 Then
                ActiveWorkbook.VBProject.VBComponents.Remove Component
            Else
                Set Modul = Component.CodeModule
                Modul.DeleteLines 1, Modul.CountOfLines
            End If
        Next
    
        ActiveSheet.DrawingObjects.Delete
        Application.DisplayAlerts = False
        
        deger = Format(Date, "yyyymmdd") & "-" & "Tarihli Sipariş Formu"
    
        ActiveWorkbook.SaveAs Filename:=kaynak & "\" & deger & ".xls", _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
        ActiveWorkbook.Close False
        
        Sheets("Sipariş").Range("a6:e65536").ClearContents
               
        MsgBox "" & deger & "" & vbLf & kaynak & vbLf & _
        "Klasörüne kayıt yapıldı.", vbInformation, "BİLGİ"
   
    
End If
End Sub

mancubus · 29 Nisan 2011

anladığım kadarı ile sadece sürücü seçmek istiyorsunuz.

aşağıdaki kodu ayrı bir modüle kopyalayın

Kod:

Private Type BrowseInfo ' used by the function GetFolderName
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
    Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
    Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) As Long

Function GetFolderName(Msg As String) As String
'http://www.exceltip.com/st/Select_folder_names_using_VBA_in_Microsoft_Excel/449.html

' returns the name of the folder selected by the user
Dim bInfo As BrowseInfo, path As String, r As Long
Dim X As Long, pos As Integer
    
    bInfo.pidlRoot = 0& ' Root folder = Desktop
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
        ' the dialog title
    Else
        bInfo.lpszTitle = Msg ' the dialog title
    End If
    bInfo.ulFlags = &H1 ' Type of directory to return
    X = SHBrowseForFolder(bInfo) ' display the dialog
    ' Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal X, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetFolderName = Left(path, pos - 1)
    Else
        GetFolderName = ""
    End If

End Function

mancubus · 29 Nisan 2011

kendi kodunuzu da aşağıdaki gibi değiştirin.

oluşması halinde hata döndürmesi için DisplayAlerts özelliğini devre dışı bırakmadım. siz başta = False diyerek bırakabilir, sonda = True diyerek tekrar geri getirebilirsiniz.

Kod:

Dim Component As Object, VBComponents As Object, Modul As Object
Dim kaynak As String, klasor As String, sayfa As String, deger As String
Dim ws As Worksheet
 
Application.ScreenUpdating = False

'kaynak = "C:\"
kaynak = GetFolderName("Sürücü Seçiniz")
If Right(kaynak, 1) <> "\" Then kaynak = kaynak & "\"

'klasor = Application.InputBox(Prompt:="Klasör ismi yazınız.", Title:="K L A S Ö R", Type:=2)
klasor = "Siparişler"
kaynak = kaynak & klasor

If Not CreateObject("Scripting.FileSystemObject").FolderExists(kaynak) Then
    CreateObject("Scripting.FileSystemObject").CreateFolder (kaynak)
End If

sayfa = Application.InputBox(Prompt:="Sayfa ismi yazınız.", Title:="S A Y F A", Type:=2)

Set ws = Worksheets(sayfa)
If Err > 0 Then
    MsgBox "Sayfa bulunamadı!" & vbCrLf & "Geçerli bir sayfa ismi yazınız!"
    Err.Clear
    Exit Sub
End If

If ws.Range("B6") = "" Then
    MsgBox "Kayıt Yapılacak Veri Bulunamadı.", vbInformation, "B İ L G İ"
    Exit Sub
Else
    ws.Copy
    For Each Component In ActiveWorkbook.VBProject.VBComponents
        If Component.Type <> 100 Then
            ActiveWorkbook.VBProject.VBComponents.Remove Component
        Else
            Set Modul = Component.CodeModule
            Modul.DeleteLines 1, Modul.CountOfLines
        End If
    Next
    ActiveSheet.DrawingObjects.Delete
    deger = Format(Date, "yyyymmdd") & "-" & "Tarihli Sipariş Formu"
    ActiveWorkbook.SaveAs Filename:=kaynak & "\" & deger & ".xls", _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
        ActiveWorkbook.Close False
    ws.Range("A6:E65536").ClearContents
    MsgBox deger & vbLf & kaynak & vbLf & "Klasörüne kayıt yapıldı.", vbInformation, "BİLGİ"
End If

Application.ScreenUpdating = True

mbldn · 29 Nisan 2011

Sayın mancubus;
ilginiz ve yardımlarınız için teşekkür ederim.
saygılarımla...

mancubus' Alıntı:

kendi kodunuzu da aşağıdaki gibi değiştirin.

oluşması halinde hata döndürmesi için DisplayAlerts özelliğini devre dışı bırakmadım. siz başta = False diyerek bırakabilir, sonda = True diyerek tekrar geri getirebilirsiniz.

Kod:

Dim Component As Object, VBComponents As Object, Modul As Object
Dim kaynak As String, klasor As String, sayfa As String, deger As String
Dim ws As Worksheet
 
Application.ScreenUpdating = False

'kaynak = "C:\"
kaynak = GetFolderName("Sürücü Seçiniz")
If Right(kaynak, 1) <> "\" Then kaynak = kaynak & "\"

'klasor = Application.InputBox(Prompt:="Klasör ismi yazınız.", Title:="K L A S Ö R", Type:=2)
klasor = "Siparişler"
kaynak = kaynak & klasor

If Not CreateObject("Scripting.FileSystemObject").FolderExists(kaynak) Then
    CreateObject("Scripting.FileSystemObject").CreateFolder (kaynak)
End If

sayfa = Application.InputBox(Prompt:="Sayfa ismi yazınız.", Title:="S A Y F A", Type:=2)

Set ws = Worksheets(sayfa)
If Err > 0 Then
    MsgBox "Sayfa bulunamadı!" & vbCrLf & "Geçerli bir sayfa ismi yazınız!"
    Err.Clear
    Exit Sub
End If

If ws.Range("B6") = "" Then
    MsgBox "Kayıt Yapılacak Veri Bulunamadı.", vbInformation, "B İ L G İ"
    Exit Sub
Else
    ws.Copy
    For Each Component In ActiveWorkbook.VBProject.VBComponents
        If Component.Type <> 100 Then
            ActiveWorkbook.VBProject.VBComponents.Remove Component
        Else
            Set Modul = Component.CodeModule
            Modul.DeleteLines 1, Modul.CountOfLines
        End If
    Next
    ActiveSheet.DrawingObjects.Delete
    deger = Format(Date, "yyyymmdd") & "-" & "Tarihli Sipariş Formu"
    ActiveWorkbook.SaveAs Filename:=kaynak & "\" & deger & ".xls", _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
        ActiveWorkbook.Close False
    Sheets("Sipariş").Range("A6:E65536").ClearContents
    MsgBox deger & vbLf & kaynak & vbLf & "Klasörüne kayıt yapıldı.", vbInformation, "BİLGİ"
End If

Application.ScreenUpdating = True

mancubus · 29 Nisan 2011

rica ederim.

ilgili satırı da aşağıdaki gibi değiştirirsek mantığa daha uygun olacak.

Kod:

    ws.Range("A6:E65536").ClearContents

Çalışma sayfasını kitap olarak kaydetme

mbldn

mancubus

Destek Ekibi

mancubus

Destek Ekibi

mbldn

mancubus

Destek Ekibi