DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub KOD()
On Error Resume Next
Dim S1 As Worksheet: Set S1 = Sheets("Sayfa1")
Dim SY As Worksheet: Set SY = Sheets("yollar")
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
SY.Range("A:A").ClearContents
Dim ds, dc, f, s
Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.GetFolder(S1.Range("B1"))
Set dc = f.Files
For Each Dosya In dc
c = c + 1
SY.Cells(c, 1) = Dosya.Name
Next
For i = 4 To S1.Cells(Rows.Count, "B").End(3).Row
If S1.Cells(i, "B") <> "" Then
For a = 1 To SY.Cells(Rows.Count, "A").End(3).Row
If SY.Cells(a, "A") Like "*" & S1.Cells(i, "B") & "*" Then
Yol = S1.Range("B1") & "\" & SY.Cells(a, "A")
GoTo Atla2
End If
Next a
GoTo atla1
Atla2:
Dim xlOutlook As Object
Dim xlMail As Object
Set xlOutlook = CreateObject("Outlook.Application")
Set xlMail = xlOutlook.CreateItem(0)
With xlMail
.To = S1.Cells(i, "E").Value
.CC = S1.Cells(i, "F").Value
.BcC = S1.Cells(i, "G").Value
.Subject = S1.Cells(i, "C").Value
.Body = S1.Cells(i, "D").Value
.Attachments.Add Yol
.Display
.Send
End With
Yol = Empty
End If
Set xlMail = Nothing
Set xlOutlook = Nothing
Next i
atla1:
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub