üstüne kayıt yaparken sorma işlemi için koda ilave

Katılım
25 Ocak 2006
Mesajlar
514
Beğeniler
5
Excel Vers. ve Dili
2019 tr
#1
aşağıdaki koda ne eklersem, eğer aynı isimde bir pdf varsa, değiştirmek istermisin diye sorar. bu hali ile sorgusuz üstüne kayıt yapıyor.

Kod:
Sub PrintAllSheetsToPDF()
'SUBROUTINE: PrintAllSheetsToPDF
'DEVELOPER: Ryan Wells
'DESCRIPTION: Combine all your worksheets into one PDF
Dim strSheets() As String
Dim strfile As String
Dim sh As Worksheet
Dim icount As Integer
Dim myfile As Variant
Set GR = Sheets("GİRİŞLER")
'Save Chart Sheet names to an Array
For Each sh In ActiveWorkbook.Worksheets
If sh.Visible = xlSheetVisible Then
ReDim Preserve strSheets(icount)
strSheets(icount) = sh.Name
icount = icount + 1
End If
Next sh
If icount = 0 Then 'No charts found. Punch error
MsgBox "DOSYA OLUŞTURULAMIYOR, OLUŞTURULACAK SAYFA YOK.", , "SAYFA BULUNAMADI"
Exit Sub
End If
'Prompt for save location
strfile = GR.[c3].Value & " AYI HARCIRAH VE OLURLARI " _
& Format(Now(), "DD.MM.YYYY") _
& ".pdf"
strfile = ThisWorkbook.Path & "\" & strfile
myfile = Application.GetSaveAsFilename _
(InitialFileName:=strfile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="NEREYE KAYDEDECEKSEN SEÇ")
If myfile <> "False" Then 'save as PDF
ThisWorkbook.Sheets(strSheets).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
myfile, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=True
GR.Select
Else
MsgBox "Sen Bilirsin", vbOKOnly, "Vazgeçtin"
End If
End Sub
 

ÖmerBey

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2012
Mesajlar
2,735
Beğeniler
221
Excel Vers. ve Dili
2007 Türkçe
#2
Merhaba,
Kodunuza ilave edip deneyiniz.
Rich (BB code):
.
.
If myfile <> "False" Then 'save as PDF
If Dir(myfile) <> "" Then
    onay = MsgBox(myfile & vbLf & "dosyası zaten var, üzerine yazılsın mı?", vbYesNo)
    If onay = vbYes Then
        ThisWorkbook.Sheets(strSheets).Select
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        myfile, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, OpenAfterPublish:=True
        GR.Select
    Else
        Exit Sub
    End If
End If
Else
.
.
 

ÖmerBey

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2012
Mesajlar
2,735
Beğeniler
221
Excel Vers. ve Dili
2007 Türkçe
#4
Rica ederim,
Deneme fırsatım olmadı ama umarım çalışmıştır.
İyi çalışmalar...
 

ÖmerBey

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2012
Mesajlar
2,735
Beğeniler
221
Excel Vers. ve Dili
2007 Türkçe
#6
Denedim oldu, yada ben yapmak istediğinizi yanlış anladım.
Çıkan soruya evet derseniz kayıt işlemi yapar, hayır derseniz kodu sonlandırır.
Rich (BB code):
Sub PrintAllSheetsToPDF()
'SUBROUTINE: PrintAllSheetsToPDF
'DEVELOPER: Ryan Wells
'DESCRIPTION: Combine all your worksheets into one PDF
Dim strSheets() As String
Dim strfile As String
Dim sh As Worksheet
Dim icount As Integer
Dim myfile As Variant
Set GR = Sheets("GİRİŞLER")
'Save Chart Sheet names to an Array
For Each sh In ActiveWorkbook.Worksheets
If sh.Visible = xlSheetVisible Then
ReDim Preserve strSheets(icount)
strSheets(icount) = sh.Name
icount = icount + 1
End If
Next sh
If icount = 0 Then 'No charts found. Punch error
MsgBox "DOSYA OLUŞTURULAMIYOR, OLUŞTURULACAK SAYFA YOK.", , "SAYFA BULUNAMADI"
Exit Sub
End If
'Prompt for save location
strfile = GR.[c3].Value & " AYI HARCIRAH VE OLURLARI " _
& Format(Now(), "DD.MM.YYYY") _
& ".pdf"
strfile = ThisWorkbook.Path & "\" & strfile
myfile = Application.GetSaveAsFilename _
(InitialFileName:=strfile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="NEREYE KAYDEDECEKSEN SEÇ")
If myfile <> "False" Then 'save as PDF
If Dir(myfile) <> "" Then
    onay = MsgBox(myfile & vbLf & "dosyası zaten var, üzerine yazılsın mı?", vbYesNo)
    If onay = vbYes Then
        ThisWorkbook.Sheets(strSheets).Select
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        myfile, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, OpenAfterPublish:=True
        GR.Select
    Else
        Exit Sub
    End If
Else
    ThisWorkbook.Sheets(strSheets).Select
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    myfile, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, OpenAfterPublish:=True
    GR.Select
End If
Else
MsgBox "Sen Bilirsin", vbOKOnly, "Vazgeçtin"
End If
End Sub
 
Son düzenleme:
Katılım
25 Ocak 2006
Mesajlar
514
Beğeniler
5
Excel Vers. ve Dili
2019 tr
#7
ilk kez kayıt yapacaksam eğer yani kaydedeceğim isim ile aynı dosya yoksa, pdf kaydı yapmıyor artık. eğer zaten bir dosya varsa ve aynı isimle kayıt yapmaya çalışırsam dediğiniz gibi çalışıyor.
 

ÖmerBey

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2012
Mesajlar
2,735
Beğeniler
221
Excel Vers. ve Dili
2007 Türkçe
#8
Haklısınız, öbür tarafa odaklanınca o kısmı kaçırmışım.
Yukarıdaki kodu güncelledim.
 

ÖmerBey

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2012
Mesajlar
2,735
Beğeniler
221
Excel Vers. ve Dili
2007 Türkçe
#10
Rica ederim,
İyi çalışmalar...
 
Üst