ozgurpeh
Altın Üye
- Katılım
- 30 Eylül 2007
- Mesajlar
- 383
- Excel Vers. ve Dili
- 2010 Türkçe
- Altın Üyelik Bitiş Tarihi
- 04-01-2027
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
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