• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Yeni Klasör açacak ve 6 sayfayı pdf kaydedecek

H

heavysharpa

Katılım
7 Şubat 2011
Mesajlar
27
Excel Vers. ve Dili
2010 enterprise
Arkadaşlar, aşağıdaki kodda yapmak istediğim; hangi ay içinde isek o ay adında klasör açacak ve o klasörün içine o gün tarihli klasör açacak ve arkasına excel çalışma sayfamdaki bir hücredeki 7 haneli rakamaı ekleyecek.
Şöyleki;
C:\Panjur\Siparişleriniz\Mayıs\08.05.2015 20150020 gibi

Bu klasörün içine çalışma sayfamdaki 6 farklı isimdeki sayfayı pdf olarak kaydedecek. Ve fakat sadece sayfa1 kaydediyor.
Diğer sayfa adları;

KULLANILANLAR
TEKLIFTL
GRAFIKLER1
GRAFIKLER2
FORUMDOKUM

Yardımcı olursanız süper olacak




Private Sub CommandButton2_Click() ' SİPARİŞ KAYDET

Dim tkno As Long, s1 As String, s2 As String, s3 As String, s4 As String, s5 As String ' teklif no otomatik atama


Dim yaz, i As Integer, a As Integer, say As Long, environ As Object
'DefObj O
'DefStr S

tkno = Sheets("BILGILER").Range("b3").Value
yol = ("c:\Panjur\Siparişleriniz\")
If Sheets("Sayfa1").Range("r7").Value = "EVET" Then


'Sub evnKlasorAcPdfKaydet()
Set objEvn = CreateObject("scripting.filesystemobject")
Set objShell = CreateObject("WScript.Shell")
strYol = ("c:\Panjur\Siparişleriniz\")
strAy = Format(Date, "mmmm")
strtarih = Format(Date, "dd.mm.yyyy")
strAd = Sheets("BILGILER").Range("b3").Value
10 If objEvn.folderexists(strYol & "\" & strAy) Then
20 If objEvn.folderexists(strYol & "\" & strAy & "\" & strtarih & " " & strAd) Then
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=strYol & "\" & strAy & "\" & strtarih & " " & strAd & "\" & _
strAd & Format(Now, "dd_mm_yyyy_hh_mm_ss.pdf")





ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Panjur\Siparişleriniz" & "\" & Filename & ".pdf" _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False

Else
mkdir strYol & "\" & strAy & "\" & strtarih & " " & strAd


GoTo 20
End If
Else
mkdir strYol & "\" & strAy
GoTo 10
End If
strtarih = vbNullString
Set objEvn = Nothing: Set objShell = Nothing
strAy = vbNullString: strAd = vbNullString: strYol = vbNullString
MsgBox "İşlem tamamlanmıştır. ", vbInformation, "Www.ExcelVBA.Net"


'ActiveWorkbook.SaveAs "C:\Panjur\Sipariş No\" & tkno & ".xls"

MsgBox Sheets("BILGILER").Range("b3") & " Sipariş No olarak kaydedildi.." ' vbAbortRetryIgnoreInformation, "www.excelvba.net"

MsgBox " GİRİLEN VERİLER. SİPARİŞ OLARAK KAYDEİLDİ. SİPARİŞ NO - TARİH ATAMALI OLARAK KAYDEDİLDİ....!!!"

Else

MsgBox " SİPARİŞİNİZ ONAYLANMADIĞI İÇİN KAYIT YAPILAMAZ.!!! TEKRAR KONTROL EDİNİZ..!!"

Exit Sub

End If




End Sub
 
Kod: 
20 If objEvn.folderexists(strYol & "\" & strAy & "\" & strtarih & " " & strAd) Then

yukarıdaki bölümden sonra aşağıdaki bölümü ekleyin ve sayfa isimlerini kendi dosyanızdakileri yazın.

Kod: 
Sheets(Array([COLOR="Red"]"Sayfa1", "Sayfa2", "Sayfa3", "Sayfa4", "Sayfa5", "Sayfa6"[/COLOR])).Select
 
Gayet güzel oldu ve fakat subscript out of range hatası verdi yazdığınız kod satırı
 
Sheets(Array("Sayfa1", "Sayfa11", "Sayfa18", "Sayfa20", "Sayfa48", "Sayfa23")).Select
 
Private Sub CommandButton2_Click() ' SİPARİŞ KAYDET

Dim tkno As Long, s1 As String, s2 As String, s3 As String, s4 As String, s5 As String ' teklif no otomatik atama


Dim yaz, i As Integer, a As Integer, say As Long, environ As Object
'DefObj O
'DefStr S

tkno = Sheets("BILGILER").Range("b3").Value
yol = ("c:\Panjur\Siparişleriniz\")
If Sheets("Sayfa1").Range("r7").Value = "EVET" Then




'Sub evnKlasorAcPdfKaydet()
Set objEvn = CreateObject("scripting.filesystemobject")
Set objShell = CreateObject("WScript.Shell")
strYol = ("c:\Panjur\Siparişleriniz\")
strAy = Format(Date, "mmmm")
strtarih = Format(Date, "dd.mm.yyyy")
strAd = Sheets("BILGILER").Range("b3").Value
10 If objEvn.folderexists(strYol & "\" & strAy) Then
20 If objEvn.folderexists(strYol & "\" & strAy & "\" & strtarih & " " & strAd) Then
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=strYol & "\" & strAy & "\" & strtarih & " " & strAd & "\" & _
strAd & " - " & Format(Now, "dd_mm_yyyy_hh_mm_ss")


Sheets(Array("Sayfa1", "Sayfa11", "Sayfa18", "Sayfa21", "Sayfa23")).Select




Else
mkdir strYol & "\" & strAy & "\" & strtarih & " " & strAd

GoTo 20
End If
Else
mkdir strYol & "\" & strAy
GoTo 10
End If



strtarih = vbNullString
Set objEvn = Nothing: Set objShell = Nothing
strAy = vbNullString: strAd = vbNullString: strYol = vbNullString
MsgBox "İşlem tamamlanmıştır. ", vbInformation, "Www.ExcelVBA.Net"




'ActiveWorkbook.SaveAs "C:\Panjur\Sipariş No\" & tkno & ".xls"

MsgBox Sheets("BILGILER").Range("b3") & " Sipariş No olarak kaydedildi.." ' vbAbortRetryIgnoreInformation, "www.excelvba.net"

MsgBox " GİRİLEN VERİLER. SİPARİŞ OLARAK KAYDEDİLDİ. SİPARİŞ NO - TARİH ATAMALI OLARAK KAYDEDİLDİ....!!!"



Else

MsgBox " SİPARİŞİNİZ ONAYLANMADIĞI İÇİN KAYIT YAPILAMAZ.!!! TEKRAR KONTROL EDİNİZ..!!"

Exit Sub

End If

End Sub
 
kod bu şekliyle çalışıyor.

Kod: 
Private Sub CommandButton2_Click()
Dim tkno As Long, s1 As String, s2 As String, s3 As String, s4 As String, s5 As String ' teklif no otomatik atama

Dim yaz, i As Integer, a As Integer, say As Long, environ As Object

tkno = Sheets("BILGILER").Range("b3").Value

If Sheets("Sayfa1").Range("r7").Value = "EVET" Then

Set objEvn = CreateObject("scripting.filesystemobject")
Set objShell = CreateObject("WScript.Shell")
strYol = ("c:\Panjur\Siparişleriniz\")

strAy = Format(Date, "mmmm")
strtarih = Format(Date, "dd.mm.yyyy")
strAd = Sheets("BILGILER").Range("b3").Value
10 If objEvn.folderexists(strYol & "\" & strAy) Then
20 If objEvn.folderexists(strYol & "\" & strAy & "\" & strtarih & " " & strAd) Then

[COLOR="Red"]Sheets(Array("Sayfa1", "Sayfa11", "Sayfa18", "Sayfa21", "Sayfa23")).Select[/COLOR]

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=strYol & "\" & strAy & "\" & strtarih & " " & strAd & "\" & _
strAd & " - " & Format(Now, "dd_mm_yyyy_hh_mm_ss")

Else
MkDir strYol & "\" & strAy & "\" & strtarih & " " & strAd

GoTo 20
End If
Else
MkDir strYol & "\" & strAy
GoTo 10
End If

strtarih = vbNullString
Set objEvn = Nothing: Set objShell = Nothing
strAy = vbNullString: strAd = vbNullString: strYol = vbNullString
MsgBox "İşlem tamamlanmıştır. ", vbInformation, "Www.ExcelVBA.Net"
MsgBox Sheets("BILGILER").Range("b3") & " Sipariş No olarak kaydedildi.."
MsgBox " GİRİLEN VERİLER. SİPARİŞ OLARAK KAYDEDİLDİ. SİPARİŞ NO - TARİH ATAMALI OLARAK KAYDEDİLDİ....!!!"

Else

MsgBox " SİPARİŞİNİZ ONAYLANMADIĞI İÇİN KAYIT YAPILAMAZ.!!! TEKRAR KONTROL EDİNİZ..!!"

Exit Sub

End If

End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst