PDF EK

[ozgurpeh]

Arkadaşlar merhaba,

Aşağıdaki kod üzerinde nasıl bir dğeişiklik yapmalıyım ki ek PDF olarak oluşsun ve PDF in en altına y1 hücresinde yazan bilgiyi ekleyebileyim.

Destekleriniz için şimdiden teşekkürler

Dim GidecekKisi As String

satir_sayisi = Application.WorksheetFunction.CountA(Worksheets(2).Range("B:B"))


For i = 2 To satir_sayisi
Range("B2").Select
Selection.AutoFilter
Kriter = Worksheets(2).Cells(i, 2)
GidecekKisi = Worksheets(2).Cells(i, 3)

ActiveSheet.Range("$A$1:$F$1338").AutoFilter Field:=2, Criteria1:=Kriter
Range("B35").Select
Selection.CurrentRegion.Select
Selection.Copy
Workbooks.Add
Range("A1").Select
ActiveSheet.Paste
Columns("A").Select
Columns("A").EntireColumn.AutoFit
Application.CutCopyMode = False
Dosya_Yolu = "xxxp"
ChDir "xxx"
ActiveWorkbook.SaveAs Filename:=Dosya_Yolu & Kriter & ".xlsx"
ActiveWindow.Close
Selection.AutoFilter
Rapor_Mail_Gonder Kriter, GidecekKisi
Next i
End Sub

Sub Rapor_Mail_Gonder(xKriter As String, xGidecekKisi As String)


Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next

With OutMail
.To = xGidecekKisi
.CC = ""
.BCC = ""
.Subject = "Kalan"
.Body = Sayfa1.Range("J3" & CustRow).Value
'.Attachments.Add ActiveWorkbook.FullName
'You can add other files also like this
Dosya_Yolu = "xxx"
.Attachments.Add (Dosya_Yolu & xKriter & ".xlsx")
.Display 'or use .Display
End With

On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

 

[Korhan Ayhan]

Merhaba,

Arşiv konularını inceleyiniz.

Arama Sonuçları

 

[ozgurpeh]

Merhaba,

Arşiv konularını inceleyiniz.

Arama Sonuçları

bu kod üzerinde değişiklik yapılamaz mı ?