- Katılım
- 29 Ekim 2010
- Mesajlar
- 365
- Excel Vers. ve Dili
- Microsoft Office 365 ProPlus 64 bit
- Altın Üyelik Bitiş Tarihi
- 31-05-2024
Elimde kullanmış olduğum bir makro var fakat pdf kayıt eder iken ismi 1 2 3 gibi kayıt ediyor kayıt ismini firma ismi olarak kaydettirmek istiyorum yada sabit bir yazı ile misal ba bs mutabakat gibi , yazılım güncelleme yapılabilir mi bu yönde teşekkürler.
makro tamamı .
Kod:
End If
yol = CreateObject("WScript.Shell").specialfolders("Desktop") & "\" & SMG.Cells(i, "z").Row ".pdf"
SD.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
yol, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
makro tamamı .
Kod:
Sub KOD()
'NOT: TOOLS-REFERENCES TIKLA
'MİCROSOFT OUTLOOK 12.0 İŞARETLİ OLMALI
On Error Resume Next
Dim SD As Worksheet
Dim SM As Worksheet
Dim SMG As Worksheet
Dim SR As Worksheet
Set SD = Sheets("data")
Set SM = Sheets("mizan")
Set SMG = Sheets("mail gönder")
Set SR = Sheets("rapor")
If Selection.Column <> 3 Then Exit Sub
With Selection
ilk_sat = .Row
son_sat = .Rows.Count + ilk_sat - 1
End With
For i = ilk_sat To son_sat
If SMG.Cells(i, "C") <> "" Then
For a = 2 To SM.Cells(Rows.Count, "B").End(3).Row
If SMG.Cells(i, "C") = SM.Cells(a, "B") Then
SD.Range("B19,B45") = SM.Cells(a, "B")
If SM.Cells(a, "H") = "" Then
SD.Range("G25") = "TL"
Else
SD.Range("g25") = SM.Cells(a, "H")
End If
If SM.Cells(a, "F") > 0 Then
SD.Range("f25") = SM.Cells(a, "F")
SD.Range("h25") = "BORÇ/ALINACAK"
Else
SD.Range("F25") = SM.Cells(a, "G")
SD.Range("E26") = ""
End If
yol = CreateObject("WScript.Shell").specialfolders("Desktop") & "\" & SMG.Cells(i, "z").Row & isim & ".pdf"
SD.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
yol, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Dim objOutlook As Object
Dim objMail As Object
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = SMG.Cells(i, "E").Value
.CC = " "
.Subject = SMG.Cells(i, "c").Value & " Bakiye ve cari mutabakat hakkında"
.Attachments.Add yol
.Save
.Display
'.Send
End With
Kill yol
sonsat = SR.Cells(Rows.Count, "A").End(3).Row + 1
SR.Cells(sonsat, "A") = SMG.Cells(i, "C")
SR.Cells(sonsat, "B") = SMG.Cells(i, "D")
SR.Cells(sonsat, "C") = Now
Exit For
Else: End If
Next a
Else: End If
Next i
Set objMail = Nothing
Set objOutlook = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub