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
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,867
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
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
 
H

heavysharpa

Katılım
7 Şubat 2011
Mesajlar
27
Excel Vers. ve Dili
2010 enterprise
Gayet güzel oldu ve fakat subscript out of range hatası verdi yazdığınız kod satırı
 
H

heavysharpa

Katılım
7 Şubat 2011
Mesajlar
27
Excel Vers. ve Dili
2010 enterprise
Sheets(Array("Sayfa1", "Sayfa11", "Sayfa18", "Sayfa20", "Sayfa48", "Sayfa23")).Select
 
H

heavysharpa

Katılım
7 Şubat 2011
Mesajlar
27
Excel Vers. ve Dili
2010 enterprise
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
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,867
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
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.
Üst