Hỗ trợ: tách file gửi đính kèm email từ excel chung

[haianh89]

Hiện tại mình đang cần thực hiện gửi email cho khác nhiều đơn vị (cỡ hơn 100 cái) mỗi đơn vị bao gồm file đính kèm, người nhận, cc khác nhau.
Mình có tìm được 1 code mà cái này nó trên 1 sheet, bên mình cần thực hiện data khá lớn nên không gộp chung 1 sheet được.
Nhờ mọi người hỗ trợ xem đoạn code mình tìm được.

Sub Send_Files()
'Working in 2000-2007
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range, FileCell As Range, rng As Range
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
    'Enter the file names in the C:Z column in each row
    Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
    If cell.Value Like "?*@?*.?*" And Application.WorksheetFunction.CountA(rng) > 0 Then
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = cell.Value
            .Subject = "Testfile"
            .Body = "Hi " & cell.Offset(0, -1).Value
            For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                If Trim(FileCell) <> "" Then
                    If Dir(FileCell.Value) <> "" Then
                        .Attachments.Add FileCell.Value
                    End If
                End If
            Next FileCell
            .Diplay
            'Or use Display
        End With
        Set OutMail = Nothing
    End If
Next cell
Set OutApp = Nothing
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With
End Sub

Cảm ơn mọi người nhiều.

 

[haianh89]

Thanks mọi người.

tìm lại trên diễn đàn đã thấy có file tương tự, mình đã sửa lại theo ý mình và gửi lại cho mn nếu ai cần nhé.