PDF dosya kaydeden mevcut makroda değişiklik talebi

A

akmlyx

Altın Üye
Katılım
24 Aralık 2010
Mesajlar
185
Excel Vers. ve Dili
Excel 2010
Dili: Türkçe
Altın Üyelik Bitiş Tarihi
16-03-2025
Değerli Üstatlar Merhaba, aşağıdaki makroda değişiklik yapmak mümkün müdür acaba?

Sub YazdırmaAlanları_PDF_Yaz()
Dim i As Integer
Dim Yol As String
Dim PdfName As String
For i = 1 To 65
Select Case i
Case 1
PdfName = [B25] & ".pdf"
Case 2
PdfName = [B56] & ".pdf"
Case 3
PdfName = [B87] & ".pdf"
Case 4
PdfName = [B118] & ".pdf"
Case 5
PdfName = [B149] & ".pdf"
Case 6
PdfName = [B180] & ".pdf"
Case 7
PdfName = [B211] & ".pdf"
Case 8
PdfName = [B242] & ".pdf"
Case 9
PdfName = [B273] & ".pdf"
Case 10
PdfName = [B304] & ".pdf"
Case 11
PdfName = [B335] & ".pdf"
Case 12
PdfName = [B366] & ".pdf"
Case 13
PdfName = [B397] & ".pdf"
Case 14
PdfName = [B428] & ".pdf"
Case 15
PdfName = [B459] & ".pdf"
Case 16
PdfName = [B490] & ".pdf"
Case 17
PdfName = [B521] & ".pdf"
Case 18
PdfName = [B552] & ".pdf"
Case 19
PdfName = [B583] & ".pdf"
Case 20
PdfName = [B614] & ".pdf"
Case 21
PdfName = [B645] & ".pdf"
Case 22
PdfName = [B676] & ".pdf"
Case 23
PdfName = [B707] & ".pdf"
Case 24
PdfName = [B738] & ".pdf"
Case 25
PdfName = [B769] & ".pdf"
Case 26
PdfName = [B800] & ".pdf"
Case 27
PdfName = [B831] & ".pdf"
Case 28
PdfName = [B862] & ".pdf"
Case 29
PdfName = [B893] & ".pdf"
Case 30
PdfName = [B924] & ".pdf"
Case 31
PdfName = [B955] & ".pdf"
Case 32
PdfName = [B986] & ".pdf"
Case 33
PdfName = [B1017] & ".pdf"
Case 34
PdfName = [B1048] & ".pdf"
Case 35
PdfName = [B1079] & ".pdf"
Case 36
PdfName = [B1110] & ".pdf"
Case 37
PdfName = [B1141] & ".pdf"
Case 38
PdfName = [B1172] & ".pdf"
Case 39
PdfName = [B1203] & ".pdf"
Case 40
PdfName = [B1234] & ".pdf"
Case 41
PdfName = [B1265] & ".pdf"
Case 42
PdfName = [B1296] & ".pdf"
Case 43
PdfName = [B1327] & ".pdf"
Case 44
PdfName = [B1358] & ".pdf"
Case 45
PdfName = [B1389] & ".pdf"
Case 46
PdfName = [B1420] & ".pdf"
Case 47
PdfName = [B1451] & ".pdf"
Case 48
PdfName = [B1482] & ".pdf"
Case 49
PdfName = [B1513] & ".pdf"
Case 50
PdfName = [B1544] & ".pdf"
Case 51
PdfName = [B1575] & ".pdf"
Case 52
PdfName = [B1606] & ".pdf"
Case 53
PdfName = [B1637] & ".pdf"
Case 54
PdfName = [B1668] & ".pdf"
Case 55
PdfName = [B1699] & ".pdf"
Case 56
PdfName = [B1730] & ".pdf"
Case 57
PdfName = [B1761] & ".pdf"
Case 58
PdfName = [B1792] & ".pdf"
Case 59
PdfName = [B1823] & ".pdf"
Case 60
PdfName = [B1854] & ".pdf"
Case 61
PdfName = [B1885] & ".pdf"
Case 62
PdfName = [B1916] & ".pdf"
Case 63
PdfName = [B1947] & ".pdf"
Case 64
PdfName = [B1978] & ".pdf"
Case 65
PdfName = [B2009] & ".pdf"
End Select
If Len(PdfName) < 6 Then MsgBox "Sayfa İsmi Eksik": Exit Sub
Yol = Environ("USERPROFILE") & "\Desktop" & "\İşçi Ücret Bordrosu"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Yol & "\" & PdfName, From:=i, To:=i, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False
Next i
i = Empty: Yol = vbNullString: PdfName = vbNullString

MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub

Bu makro, masaüstünde manuel olarak oluşturulmuş "İşçi Ücret Bordrosu" ismindeki klasöre pdf belgeleri kaydetmekte, benim istediğim ise Excelde AA2 hücresinde yazan isimde bir klasörü kendi oluştursun sonrasında pdf belgelerini içine kaydetsin. Yani manuel klasör oluşturma son bulsun, klasör otomatik oluşsun istiyorum.
 
bycakir

bycakir

Altın Üye
Katılım
1 Aralık 2017
Mesajlar
222
Excel Vers. ve Dili
Microsoft Office 365 ProPlus
Altın Üyelik Bitiş Tarihi
18-01-2025
deneyiniz.

Sub YazdırmaAlanları_PDF_Yaz()
Dim i As Integer
Dim yol As String
Dim PdfName As String
For i = 1 To 65
Select Case i
Case 1
PdfName = [B25] & ".pdf"
Case 2
PdfName = [B56] & ".pdf"
Case 3
PdfName = [B87] & ".pdf"
Case 4
PdfName = [B118] & ".pdf"
Case 5
PdfName = [B149] & ".pdf"
Case 6
PdfName = [B180] & ".pdf"
Case 7
PdfName = [B211] & ".pdf"
Case 8
PdfName = [B242] & ".pdf"
Case 9
PdfName = [B273] & ".pdf"
Case 10
PdfName = [B304] & ".pdf"
Case 11
PdfName = [B335] & ".pdf"
Case 12
PdfName = [B366] & ".pdf"
Case 13
PdfName = [B397] & ".pdf"
Case 14
PdfName = [B428] & ".pdf"
Case 15
PdfName = [B459] & ".pdf"
Case 16
PdfName = [B490] & ".pdf"
Case 17
PdfName = [B521] & ".pdf"
Case 18
PdfName = [B552] & ".pdf"
Case 19
PdfName = [B583] & ".pdf"
Case 20
PdfName = [B614] & ".pdf"
Case 21
PdfName = [B645] & ".pdf"
Case 22
PdfName = [B676] & ".pdf"
Case 23
PdfName = [B707] & ".pdf"
Case 24
PdfName = [B738] & ".pdf"
Case 25
PdfName = [B769] & ".pdf"
Case 26
PdfName = [B800] & ".pdf"
Case 27
PdfName = [B831] & ".pdf"
Case 28
PdfName = [B862] & ".pdf"
Case 29
PdfName = [B893] & ".pdf"
Case 30
PdfName = [B924] & ".pdf"
Case 31
PdfName = [B955] & ".pdf"
Case 32
PdfName = [B986] & ".pdf"
Case 33
PdfName = [B1017] & ".pdf"
Case 34
PdfName = [B1048] & ".pdf"
Case 35
PdfName = [B1079] & ".pdf"
Case 36
PdfName = [B1110] & ".pdf"
Case 37
PdfName = [B1141] & ".pdf"
Case 38
PdfName = [B1172] & ".pdf"
Case 39
PdfName = [B1203] & ".pdf"
Case 40
PdfName = [B1234] & ".pdf"
Case 41
PdfName = [B1265] & ".pdf"
Case 42
PdfName = [B1296] & ".pdf"
Case 43
PdfName = [B1327] & ".pdf"
Case 44
PdfName = [B1358] & ".pdf"
Case 45
PdfName = [B1389] & ".pdf"
Case 46
PdfName = [B1420] & ".pdf"
Case 47
PdfName = [B1451] & ".pdf"
Case 48
PdfName = [B1482] & ".pdf"
Case 49
PdfName = [B1513] & ".pdf"
Case 50
PdfName = [B1544] & ".pdf"
Case 51
PdfName = [B1575] & ".pdf"
Case 52
PdfName = [B1606] & ".pdf"
Case 53
PdfName = [B1637] & ".pdf"
Case 54
PdfName = [B1668] & ".pdf"
Case 55
PdfName = [B1699] & ".pdf"
Case 56
PdfName = [B1730] & ".pdf"
Case 57
PdfName = [B1761] & ".pdf"
Case 58
PdfName = [B1792] & ".pdf"
Case 59
PdfName = [B1823] & ".pdf"
Case 60
PdfName = [B1854] & ".pdf"
Case 61
PdfName = [B1885] & ".pdf"
Case 62
PdfName = [B1916] & ".pdf"
Case 63
PdfName = [B1947] & ".pdf"
Case 64
PdfName = [B1978] & ".pdf"
Case 65
PdfName = [B2009] & ".pdf"
End Select
If Len(PdfName) < 6 Then MsgBox "Sayfa İsmi Eksik": Exit Sub
ad = Range("aa2")
MkDir Environ("USERPROFILE") & "\Desktop" & "\" & ad

yol = Environ("USERPROFILE") & "\Desktop" & "\" & ad
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=yol & "\" & PdfName, From:=i, To:=i, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False
Next i
i = Empty: yol = vbNullString: PdfName = vbNullString

MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub
 
A

akmlyx

Altın Üye
Katılım
24 Aralık 2010
Mesajlar
185
Excel Vers. ve Dili
Excel 2010
Dili: Türkçe
Altın Üyelik Bitiş Tarihi
16-03-2025
Path/File access error hatası veriyor hocam.
Acaba AA2 hücresinin sayfa adını mı bulamıyor diye düşündüm?
AA2 hücresinin sayfa adı : "Bordro Çoklu" olacak.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,274
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Merhaba,

Döngülerin amacı kodları mümkün olduğunca kısaltmaya çalışmaktır.

Hücre artış ritminizi (B25 hücresinden başlayıp 31 satırda bir dosya ismi yazdığınız görünüyor) tespit edip kodu kısaltmaya çalıştım. Deneyiniz.

C++: 
Option Explicit

Sub YazdırmaAlanları_PDF_Yaz()
    Dim i As Integer
    Dim Yol As String
    Dim PdfName As String
   
    For i = 1 To 65
        Select Case i
            Case 1
            PdfName = Range("B25") & ".pdf"
        Case Else
            PdfName = Range("B" & 25 + (i - 1) * 31) & ".pdf"
        End Select
       
        If Len(PdfName) < 6 Then MsgBox "Sayfa ismi eksik!", vbCritical: Exit Sub
       
        Yol = Environ("UserProfile") & "\Desktop" & "\" & Sheets("Bordro Çoklu").Range("AA2")
       
        If Dir(Yol, vbDirectory) = "" Then MkDir Yol
       
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=Yol & "\" & PdfName, From:=i, To:=i, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False
    Next i
   
    i = Empty: Yol = vbNullString: PdfName = vbNullString
   
    MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub
 
A

akmlyx

Altın Üye
Katılım
24 Aralık 2010
Mesajlar
185
Excel Vers. ve Dili
Excel 2010
Dili: Türkçe
Altın Üyelik Bitiş Tarihi
16-03-2025
@Korhan Ayhan hocam, harikasınız, elinize sağlık çok TEŞEKKÜR EDERİM. Makro gayet güzel çalışıyor. Sizden bir istirhamım olabilir mi?

Aynı Sayfayı farklı isimlerle kaydetme makrosu

Değerli Üstatlar Merhaba, Ekteki Excel'de butona bağlı olarak çalışacak makro, bilgisayarın masaüstüne bordro sayfasındaki AA11 hücresinde yazan isimde bir klasör açacak, bu klasör açıldıktan sonra Sayfa1'deki A3 hücresinden itibaren yazan ilk sayıyı bulacak bu sayıyı Bordro sayfasındaki B5...
www.excel.web.tr www.excel.web.tr
adresindeki makro konusuna da bakabilir misiniz? Şimdiden çok çok TEŞEKKÜR EDERİM.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst