Hướng dẫn gửi mail tự động (đính kèm file và bảng tổng hợp)

[saobekhonglac]

Chào Anh/Chị.

Nhờ Anh/Chị giúp em code gửi mail tự động vừa đính kèm file và bảng tổng hợp. Chi tiết Anh/Chị xem nội dung bên dưới giúp Em.

File gồm 2 sheet: Chi tiet & Tong hop.

Sheet Chi tiet có 44 cột, trong đó cột U là tên Giám đốc, V là tên nhân viên. Tương ứng cột AM & AN là địa chỉ mail của Giám đốc và nhân viên
Cột AO đến AN là thông tin gửi mail, tiêu đề, Nội dung,.... (sheet này có bao nhiêu nhân viên thì sẽ xuất ra bấy nhiêu file excel với tên nhân viên đó

Sheet Tong hop có 14 cột (tiêu đề cột lấy giống như sheet Chi tiet: Dữ liệu thì liệt kê những Khách hàng của nhân viên đó ra để gửi bảng tổng hợp trong mail, có dòng tổng bên dưới thì càng tốt. (Sheet này chỉ tổng hợp 1 số cột chính để dán bên dưới mail, dán dạng ảnh nếu text thì phải giữ nguyên định dạng)

Ví dụ khi nhấn nút thì sẽ tự động gửi mail đến chot tất cả nhân viên có địa chỉ mail trong sheet Chi tiet và CC cho Giám đốc.

Như ví dụ đính kèm sẽ gửi cho anh HO SY PHUNG thì sheet tổng hợp sẽ liệt kê hết những Khách hàng của anh HO SY PHUNG và sheet Chi tiet sẽ xuất ra 1 file Excel chỉ hiện những Khách hàng của anh này (xuất từ cột A đến cột AL). Mail sẽ gửi cho anh PHUNG và cc cho a THANGAnh/Chị xem mail mẫu giúp em.

 

[saobekhonglac]

Anh/Chị giúp em với.

 

[saobekhonglac]

Anh/Chị giúp em với.

Hix

 

[vanthinh3101]

Chào Anh/Chị.

Nhờ Anh/Chị giúp em code gửi mail tự động vừa đính kèm file và bảng tổng hợp. Chi tiết Anh/Chị xem nội dung bên dưới giúp Em.

File gồm 2 sheet: Chi tiet & Tong hop.

Sheet Chi tiet có 44 cột, trong đó cột U là tên Giám đốc, V là tên nhân viên. Tương ứng cột AM & AN là địa chỉ mail của Giám đốc và nhân viên
Cột AO đến AN là thông tin gửi mail, tiêu đề, Nội dung,.... (sheet này có bao nhiêu nhân viên thì sẽ xuất ra bấy nhiêu file excel với tên nhân viên đó

Sheet Tong hop có 14 cột (tiêu đề cột lấy giống như sheet Chi tiet: Dữ liệu thì liệt kê những Khách hàng của nhân viên đó ra để gửi bảng tổng hợp trong mail, có dòng tổng bên dưới thì càng tốt. (Sheet này chỉ tổng hợp 1 số cột chính để dán bên dưới mail, dán dạng ảnh nếu text thì phải giữ nguyên định dạng)

Ví dụ khi nhấn nút thì sẽ tự động gửi mail đến chot tất cả nhân viên có địa chỉ mail trong sheet Chi tiet và CC cho Giám đốc.

Như ví dụ đính kèm sẽ gửi cho anh HO SY PHUNG thì sheet tổng hợp sẽ liệt kê hết những Khách hàng của anh HO SY PHUNG và sheet Chi tiet sẽ xuất ra 1 file Excel chỉ hiện những Khách hàng của anh này (xuất từ cột A đến cột AL). Mail sẽ gửi cho anh PHUNG và cc cho a THANGAnh/Chị xem mail mẫu giúp em.

Tạm vậy đã.
Chưa có thời gian nghĩ tiếp.

 

[vanthinh3101]

Chào Anh/Chị.

Nhờ Anh/Chị giúp em code gửi mail tự động vừa đính kèm file và bảng tổng hợp. Chi tiết Anh/Chị xem nội dung bên dưới giúp Em.

File gồm 2 sheet: Chi tiet & Tong hop.

Sheet Chi tiet có 44 cột, trong đó cột U là tên Giám đốc, V là tên nhân viên. Tương ứng cột AM & AN là địa chỉ mail của Giám đốc và nhân viên
Cột AO đến AN là thông tin gửi mail, tiêu đề, Nội dung,.... (sheet này có bao nhiêu nhân viên thì sẽ xuất ra bấy nhiêu file excel với tên nhân viên đó

Sheet Tong hop có 14 cột (tiêu đề cột lấy giống như sheet Chi tiet: Dữ liệu thì liệt kê những Khách hàng của nhân viên đó ra để gửi bảng tổng hợp trong mail, có dòng tổng bên dưới thì càng tốt. (Sheet này chỉ tổng hợp 1 số cột chính để dán bên dưới mail, dán dạng ảnh nếu text thì phải giữ nguyên định dạng)

Ví dụ khi nhấn nút thì sẽ tự động gửi mail đến chot tất cả nhân viên có địa chỉ mail trong sheet Chi tiet và CC cho Giám đốc.

Như ví dụ đính kèm sẽ gửi cho anh HO SY PHUNG thì sheet tổng hợp sẽ liệt kê hết những Khách hàng của anh HO SY PHUNG và sheet Chi tiet sẽ xuất ra 1 file Excel chỉ hiện những Khách hàng của anh này (xuất từ cột A đến cột AL). Mail sẽ gửi cho anh PHUNG và cc cho a THANGAnh/Chị xem mail mẫu giúp em.

Cuối cùng cũng làm chỉnh chu được cho bạn.
Cũng nhờ bác @befaint mách nước cho tại bài #5: https://www.giaiphapexcel.com/diendan/threads/gửi-email-từ-excel-bằng-vba.122394/post-767131
Bạn xem file đính kèm.

 

[saobekhonglac]

Cuối cùng cũng làm chỉnh chu được cho bạn.
Cũng nhờ bác @befaint mách nước cho tại bài #5: https://www.giaiphapexcel.com/diendan/threads/gửi-email-từ-excel-bằng-vba.122394/post-767131
Bạn xem file đính kèm.

Cám ơn anh đã chịu khó làm giúp em, em đã test và còn vướng 2 trường hợp sau:

1. Mail chỉ gửi được cho 1 người đầu tiên, các người còn lại có xuất file đính kèm nhưng không gửi mail.
2. Bảng tổng hợp đính kèm vào nội dung mail khi em thay đổi tiêu để cột khác thì dữ liệu vẫn không đổi (ví dụ cột N là "GSKD" đổi thành "Quá hạn trên 90 ngày" thì khi mail gửi vân copy nội dung cột "GSKD". Format (màu) của bảng tổng hợp cũng khác so với file gốc (giúp em định dạng y như format ban đầu của file gốc (cả file đính kèm và bảng tổng hợp trong nội dung mail).

Anh có thể giúp em hoàn chỉnh file đính kèm cho bảng tổng định dạng được như file gốc (dạng số phải canh phải thì mới dễ nhìn).
Nhờ anh giúp em cho trót,

Cám ơn anh rất nhiều.

 

[vanthinh3101]

Cám ơn anh đã chịu khó làm giúp em, em đã test và còn vướng 2 trường hợp sau:

1. Mail chỉ gửi được cho 1 người đầu tiên, các người còn lại có xuất file đính kèm nhưng không gửi mail.
2. Bảng tổng hợp đính kèm vào nội dung mail khi em thay đổi tiêu để cột khác thì dữ liệu vẫn không đổi (ví dụ cột N là "GSKD" đổi thành "Quá hạn trên 90 ngày" thì khi mail gửi vân copy nội dung cột "GSKD". Format (màu) của bảng tổng hợp cũng khác so với file gốc (giúp em định dạng y như format ban đầu của file gốc (cả file đính kèm và bảng tổng hợp trong nội dung mail).

Anh có thể giúp em hoàn chỉnh file đính kèm cho bảng tổng định dạng được như file gốc (dạng số phải canh phải thì mới dễ nhìn).
Nhờ anh giúp em cho trót,

Cám ơn anh rất nhiều.

Bạn thay code ở Module2

Sub SpitFilesAndEmail()
    Dim sArr(), tArr(), dArr(), iArr()
    Dim OutlookApp As Object, OutlookMail As Object
    Dim Wb As Workbook, Header As Range, Rng As Range, FileName As String
    Dim I As Long, J As Long, K As Long, H As Long
      
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    sArr() = Sheet1.Range("A2", Sheet1.Range("A2").End(xlDown)).Resize(, 38).Value
    tArr() = Sheet3.Range("A2", Sheet3.Range("A2").End(xlDown)).Resize(, 8).Value
    Set Header = Sheet1.Range("A1").Resize(, 38)
    
    For I = 1 To UBound(tArr, 1)
        FileName = ThisWorkbook.Path & "\" & tArr(I, 2) & ".xlsx"
        ReDim dArr(1 To UBound(sArr, 1), 1 To 38)
        ReDim iArr(1 To UBound(sArr, 1), 1 To 14)
        K = 0
        For J = 1 To UBound(sArr, 1)
            If sArr(J, 22) = tArr(I, 2) Then
                K = K + 1
                For H = 1 To 38
                     dArr(K, H) = sArr(J, H)
                Next H
                
                iArr(K, 1) = sArr(J, 3): iArr(K, 2) = sArr(J, 4): iArr(K, 3) = sArr(J, 5)
                For H = 9 To 17
                    iArr(K, H - 5) = sArr(J, H)
                Next H
                iArr(K, 13) = sArr(J, 21): iArr(K, 14) = sArr(J, 22)
            End If
        Next J
        If K Then
            Set Wb = Workbooks.Add
            With Wb.Worksheets(1)
                Header.Copy .Range("A1")
                .Range("A2").Resize(K, 38) = dArr
                .Range("A1").Resize(, 38).EntireColumn.AutoFit
                .Range("E2:Q2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("Y2:AB2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("AD2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("AF2:AG2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("AL2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("AC2").Resize(K).NumberFormat = "0.00%"
                .Range("AE2").Resize(K).NumberFormat = "0.00%"
                .Range("AH2").Resize(K).NumberFormat = "0.00%"
                .SaveAs FileName
            End With
            Wb.Close
            Erase dArr
            
            With Sheet2
                .Rows("1:151").EntireRow.Hidden = False
                .Range("A3:N150").ClearContents
                .Range("A3").Resize(K, 14) = iArr
                .Range("A3:N3").EntireColumn.AutoFit
                .Rows((K + 3) & ":150").EntireRow.Hidden = True
                Set Rng = .Range("A1:N151").SpecialCells(xlCellTypeVisible)
            End With
            Erase iArr
      
            Set OutlookApp = CreateObject("Outlook.Application")
            Set OutlookMail = OutlookApp.CreateItem(0)
            On Error Resume Next
            With OutlookMail
                .To = tArr(I, 4)
                .Cc = tArr(I, 3)
                .Bcc = ""
                .Subject = tArr(I, 5)
                .HTMLBody = tArr(I, 6) & "<br>" & "<br>" & tArr(I, 7) & "<br>"
                .HTMLBody = .HTMLBody & RangetoHTML(Rng)
                .HTMLBody = .HTMLBody & "<br>" & tArr(I, 8)
                .Attachments.Add FileName
                '.Display
                .Send
            End With
            On Error Resume Next
            Set OutlookApp = Nothing: Set OutlookMail = Nothing
        End If
    Next I
  
    Set Header = Nothing
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

1. Mail chỉ gửi được cho 1 người đầu tiên, các người còn lại có xuất file đính kèm nhưng không gửi mail --> đã giải quyết xong.
2. Bảng tổng hợp đính kèm vào nội dung mail khi em thay đổi tiêu để cột khác thì dữ liệu vẫn không đổi (ví dụ cột N là "GSKD" đổi thành "Quá hạn trên 90 ngày" thì khi mail gửi vân copy nội dung cột "GSKD" --> nếu bạn thay đổi cấu trúc dữ liệu thì phải đưa Template mới lên rồi tôi sửa tương ứng (hoặc bạn có thể tự sửa code).
Format (màu) của bảng tổng hợp cũng khác so với file gốc (giúp em định dạng y như format ban đầu của file gốc (cả file đính kèm và bảng tổng hợp trong nội dung mail) --> màu thì tôi chịu thôi, khi chuyển sang dạng HTML thì nó ra màu như vậy, tôi không rành về vụ này, chỉ là cóp nhặt của người khác để sử dụng.

 

[saobekhonglac]

Bạn thay code ở Module2

Sub SpitFilesAndEmail()
    Dim sArr(), tArr(), dArr(), iArr()
    Dim OutlookApp As Object, OutlookMail As Object
    Dim Wb As Workbook, Header As Range, Rng As Range, FileName As String
    Dim I As Long, J As Long, K As Long, H As Long
     
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    sArr() = Sheet1.Range("A2", Sheet1.Range("A2").End(xlDown)).Resize(, 38).Value
    tArr() = Sheet3.Range("A2", Sheet3.Range("A2").End(xlDown)).Resize(, 8).Value
    Set Header = Sheet1.Range("A1").Resize(, 38)
   
    For I = 1 To UBound(tArr, 1)
        FileName = ThisWorkbook.Path & "\" & tArr(I, 2) & ".xlsx"
        ReDim dArr(1 To UBound(sArr, 1), 1 To 38)
        ReDim iArr(1 To UBound(sArr, 1), 1 To 14)
        K = 0
        For J = 1 To UBound(sArr, 1)
            If sArr(J, 22) = tArr(I, 2) Then
                K = K + 1
                For H = 1 To 38
                     dArr(K, H) = sArr(J, H)
                Next H
               
                iArr(K, 1) = sArr(J, 3): iArr(K, 2) = sArr(J, 4): iArr(K, 3) = sArr(J, 5)
                For H = 9 To 17
                    iArr(K, H - 5) = sArr(J, H)
                Next H
                iArr(K, 13) = sArr(J, 21): iArr(K, 14) = sArr(J, 22)
            End If
        Next J
        If K Then
            Set Wb = Workbooks.Add
            With Wb.Worksheets(1)
                Header.Copy .Range("A1")
                .Range("A2").Resize(K, 38) = dArr
                .Range("A1").Resize(, 38).EntireColumn.AutoFit
                .Range("E2:Q2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("Y2:AB2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("AD2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("AF2:AG2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("AL2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("AC2").Resize(K).NumberFormat = "0.00%"
                .Range("AE2").Resize(K).NumberFormat = "0.00%"
                .Range("AH2").Resize(K).NumberFormat = "0.00%"
                .SaveAs FileName
            End With
            Wb.Close
            Erase dArr
           
            With Sheet2
                .Rows("1:151").EntireRow.Hidden = False
                .Range("A3:N150").ClearContents
                .Range("A3").Resize(K, 14) = iArr
                .Range("A3:N3").EntireColumn.AutoFit
                .Rows((K + 3) & ":150").EntireRow.Hidden = True
                Set Rng = .Range("A1:N151").SpecialCells(xlCellTypeVisible)
            End With
            Erase iArr
     
            Set OutlookApp = CreateObject("Outlook.Application")
            Set OutlookMail = OutlookApp.CreateItem(0)
            On Error Resume Next
            With OutlookMail
                .To = tArr(I, 4)
                .Cc = tArr(I, 3)
                .Bcc = ""
                .Subject = tArr(I, 5)
                .HTMLBody = tArr(I, 6) & "<br>" & "<br>" & tArr(I, 7) & "<br>"
                .HTMLBody = .HTMLBody & RangetoHTML(Rng)
                .HTMLBody = .HTMLBody & "<br>" & tArr(I, 8)
                .Attachments.Add FileName
                '.Display
                .Send
            End With
            On Error Resume Next
            Set OutlookApp = Nothing: Set OutlookMail = Nothing
        End If
    Next I
 
    Set Header = Nothing
   
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

1. Mail chỉ gửi được cho 1 người đầu tiên, các người còn lại có xuất file đính kèm nhưng không gửi mail --> đã giải quyết xong.
2. Bảng tổng hợp đính kèm vào nội dung mail khi em thay đổi tiêu để cột khác thì dữ liệu vẫn không đổi (ví dụ cột N là "GSKD" đổi thành "Quá hạn trên 90 ngày" thì khi mail gửi vân copy nội dung cột "GSKD" --> nếu bạn thay đổi cấu trúc dữ liệu thì phải đưa Template mới lên rồi tôi sửa tương ứng (hoặc bạn có thể tự sửa code).
Format (màu) của bảng tổng hợp cũng khác so với file gốc (giúp em định dạng y như format ban đầu của file gốc (cả file đính kèm và bảng tổng hợp trong nội dung mail) --> màu thì tôi chịu thôi, khi chuyển sang dạng HTML thì nó ra màu như vậy, tôi không rành về vụ này, chỉ là cóp nhặt của người khác để sử dụng.

Dạ cám ơn anh. mail đã gửi đủ. Cái sheet Nguồn hình như mình phải liệt kê ra gửi mail nhiêu mail từ sheet chi tiết thì code mới chạy được đúng không anh.
Anh thêm giúp em chữ ký trong mail với.

 

[vanthinh3101]

Dạ cám ơn anh. mail đã gửi đủ. Cái sheet Nguồn hình như mình phải liệt kê ra gửi mail nhiêu mail từ sheet chi tiết thì code mới chạy được đúng không anh.
Anh thêm giúp em chữ ký trong mail với.

Code cập nhật

Sub SpitFilesAndEmail()
    Dim sArr(), tArr(), dArr(), iArr()
    Dim OutlookApp As Object, OutlookMail As Object
    Dim Wb As Workbook, Header As Range, Rng As Range, FileName As String
    Dim I As Long, J As Long, K As Long, H As Long
      
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    sArr() = Sheet1.Range("A2", Sheet1.Range("A2").End(xlDown)).Resize(, 38).Value
    tArr() = Sheet3.Range("A2", Sheet3.Range("A2").End(xlDown)).Resize(, 8).Value
    Set Header = Sheet1.Range("A1").Resize(, 38)
    'Lay chu ky mac dinh cua Outlook
    Signature = Environ("appdata") & "\Microsoft\Signatures\"
    If Dir(Signature, vbDirectory) <> vbNullString Then
        Signature = Signature & Dir$(Signature & "*.htm")
    Else
        Signature = ""
    End If
    Signature = CreateObject("Scripting.FileSystemObject").GetFile(Signature).OpenAsTextStream(1, -2).ReadAll
    
    For I = 1 To UBound(tArr, 1)
        FileName = ThisWorkbook.Path & "\" & tArr(I, 2) & ".xlsx"
        ReDim dArr(1 To UBound(sArr, 1), 1 To 38)
        ReDim iArr(1 To UBound(sArr, 1), 1 To 14)
        K = 0
        For J = 1 To UBound(sArr, 1)
            If sArr(J, 22) = tArr(I, 2) Then
                K = K + 1
                For H = 1 To 38
                     dArr(K, H) = sArr(J, H)
                Next H
                
                iArr(K, 1) = sArr(J, 3): iArr(K, 2) = sArr(J, 4): iArr(K, 3) = sArr(J, 5)
                For H = 9 To 17
                    iArr(K, H - 5) = sArr(J, H)
                Next H
                iArr(K, 13) = sArr(J, 21): iArr(K, 14) = sArr(J, 22)
            End If
        Next J
        If K Then
            Set Wb = Workbooks.Add
            With Wb.Worksheets(1)
                Header.Copy .Range("A1")
                .Range("A2").Resize(K, 38) = dArr
                .Range("A1").Resize(, 38).EntireColumn.AutoFit
                .Range("E2:Q2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("Y2:AB2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("AD2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("AF2:AG2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("AL2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("AC2").Resize(K).NumberFormat = "0.00%"
                .Range("AE2").Resize(K).NumberFormat = "0.00%"
                .Range("AH2").Resize(K).NumberFormat = "0.00%"
                .SaveAs FileName
            End With
            Wb.Close
            Erase dArr
            
            With Sheet2
                .Rows("1:151").EntireRow.Hidden = False
                .Range("A3:N150").ClearContents
                .Range("A3").Resize(K, 14) = iArr
                .Range("A3:N3").EntireColumn.AutoFit
                .Rows((K + 3) & ":150").EntireRow.Hidden = True
                Set Rng = .Range("A1:N151").SpecialCells(xlCellTypeVisible)
            End With
            Erase iArr
      
            Set OutlookApp = CreateObject("Outlook.Application")
            Set OutlookMail = OutlookApp.CreateItem(0)
            On Error Resume Next
            With OutlookMail
                .To = tArr(I, 4)
                .Cc = tArr(I, 3)
                .Bcc = ""
                .Subject = tArr(I, 5)
                .HTMLBody = tArr(I, 6) & "<br>" & "<br>" & tArr(I, 7) & "<br>"
                .HTMLBody = .HTMLBody & RangetoHTML(Rng)
                .HTMLBody = .HTMLBody & "<br>" & tArr(I, 8)
                .Attachments.Add FileName
                '.Display
                .Send
            End With
            On Error Resume Next
            Set OutlookApp = Nothing: Set OutlookMail = Nothing
        End If
    Next I
  
    Set Header = Nothing
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Ở sheet Nguon bạn liệt kê danh sách email cần gửi.
Mà tôi nghĩ tốt nhất là bạn nên lấy mã nhân viên làm gốc, vì không lo tên giống nhau, tránh nhầm lẫn.

 

[saobekhonglac]

Code cập nhật

Sub SpitFilesAndEmail()
    Dim sArr(), tArr(), dArr(), iArr()
    Dim OutlookApp As Object, OutlookMail As Object
    Dim Wb As Workbook, Header As Range, Rng As Range, FileName As String
    Dim I As Long, J As Long, K As Long, H As Long
     
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    sArr() = Sheet1.Range("A2", Sheet1.Range("A2").End(xlDown)).Resize(, 38).Value
    tArr() = Sheet3.Range("A2", Sheet3.Range("A2").End(xlDown)).Resize(, 8).Value
    Set Header = Sheet1.Range("A1").Resize(, 38)
    'Lay chu ky mac dinh cua Outlook
    Signature = Environ("appdata") & "\Microsoft\Signatures\"
    If Dir(Signature, vbDirectory) <> vbNullString Then
        Signature = Signature & Dir$(Signature & "*.htm")
    Else
        Signature = ""
    End If
    Signature = CreateObject("Scripting.FileSystemObject").GetFile(Signature).OpenAsTextStream(1, -2).ReadAll
   
    For I = 1 To UBound(tArr, 1)
        FileName = ThisWorkbook.Path & "\" & tArr(I, 2) & ".xlsx"
        ReDim dArr(1 To UBound(sArr, 1), 1 To 38)
        ReDim iArr(1 To UBound(sArr, 1), 1 To 14)
        K = 0
        For J = 1 To UBound(sArr, 1)
            If sArr(J, 22) = tArr(I, 2) Then
                K = K + 1
                For H = 1 To 38
                     dArr(K, H) = sArr(J, H)
                Next H
               
                iArr(K, 1) = sArr(J, 3): iArr(K, 2) = sArr(J, 4): iArr(K, 3) = sArr(J, 5)
                For H = 9 To 17
                    iArr(K, H - 5) = sArr(J, H)
                Next H
                iArr(K, 13) = sArr(J, 21): iArr(K, 14) = sArr(J, 22)
            End If
        Next J
        If K Then
            Set Wb = Workbooks.Add
            With Wb.Worksheets(1)
                Header.Copy .Range("A1")
                .Range("A2").Resize(K, 38) = dArr
                .Range("A1").Resize(, 38).EntireColumn.AutoFit
                .Range("E2:Q2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("Y2:AB2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("AD2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("AF2:AG2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("AL2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("AC2").Resize(K).NumberFormat = "0.00%"
                .Range("AE2").Resize(K).NumberFormat = "0.00%"
                .Range("AH2").Resize(K).NumberFormat = "0.00%"
                .SaveAs FileName
            End With
            Wb.Close
            Erase dArr
           
            With Sheet2
                .Rows("1:151").EntireRow.Hidden = False
                .Range("A3:N150").ClearContents
                .Range("A3").Resize(K, 14) = iArr
                .Range("A3:N3").EntireColumn.AutoFit
                .Rows((K + 3) & ":150").EntireRow.Hidden = True
                Set Rng = .Range("A1:N151").SpecialCells(xlCellTypeVisible)
            End With
            Erase iArr
     
            Set OutlookApp = CreateObject("Outlook.Application")
            Set OutlookMail = OutlookApp.CreateItem(0)
            On Error Resume Next
            With OutlookMail
                .To = tArr(I, 4)
                .Cc = tArr(I, 3)
                .Bcc = ""
                .Subject = tArr(I, 5)
                .HTMLBody = tArr(I, 6) & "<br>" & "<br>" & tArr(I, 7) & "<br>"
                .HTMLBody = .HTMLBody & RangetoHTML(Rng)
                .HTMLBody = .HTMLBody & "<br>" & tArr(I, 8)
                .Attachments.Add FileName
                '.Display
                .Send
            End With
            On Error Resume Next
            Set OutlookApp = Nothing: Set OutlookMail = Nothing
        End If
    Next I
 
    Set Header = Nothing
   
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Ở sheet Nguon bạn liệt kê danh sách email cần gửi.
Mà tôi nghĩ tốt nhất là bạn nên lấy mã nhân viên làm gốc, vì không lo tên giống nhau, tránh nhầm lẫn.

Dạ cám ơn anh

 

[saobekhonglac]

Code cập nhật

Sub SpitFilesAndEmail()
    Dim sArr(), tArr(), dArr(), iArr()
    Dim OutlookApp As Object, OutlookMail As Object
    Dim Wb As Workbook, Header As Range, Rng As Range, FileName As String
    Dim I As Long, J As Long, K As Long, H As Long
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    sArr() = Sheet1.Range("A2", Sheet1.Range("A2").End(xlDown)).Resize(, 38).Value
    tArr() = Sheet3.Range("A2", Sheet3.Range("A2").End(xlDown)).Resize(, 8).Value
    Set Header = Sheet1.Range("A1").Resize(, 38)
    'Lay chu ky mac dinh cua Outlook
    Signature = Environ("appdata") & "\Microsoft\Signatures\"
    If Dir(Signature, vbDirectory) <> vbNullString Then
        Signature = Signature & Dir$(Signature & "*.htm")
    Else
        Signature = ""
    End If
    Signature = CreateObject("Scripting.FileSystemObject").GetFile(Signature).OpenAsTextStream(1, -2).ReadAll
  
    For I = 1 To UBound(tArr, 1)
        FileName = ThisWorkbook.Path & "\" & tArr(I, 2) & ".xlsx"
        ReDim dArr(1 To UBound(sArr, 1), 1 To 38)
        ReDim iArr(1 To UBound(sArr, 1), 1 To 14)
        K = 0
        For J = 1 To UBound(sArr, 1)
            If sArr(J, 22) = tArr(I, 2) Then
                K = K + 1
                For H = 1 To 38
                     dArr(K, H) = sArr(J, H)
                Next H
              
                iArr(K, 1) = sArr(J, 3): iArr(K, 2) = sArr(J, 4): iArr(K, 3) = sArr(J, 5)
                For H = 9 To 17
                    iArr(K, H - 5) = sArr(J, H)
                Next H
                iArr(K, 13) = sArr(J, 21): iArr(K, 14) = sArr(J, 22)
            End If
        Next J
        If K Then
            Set Wb = Workbooks.Add
            With Wb.Worksheets(1)
                Header.Copy .Range("A1")
                .Range("A2").Resize(K, 38) = dArr
                .Range("A1").Resize(, 38).EntireColumn.AutoFit
                .Range("E2:Q2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("Y2:AB2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("AD2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("AF2:AG2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("AL2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("AC2").Resize(K).NumberFormat = "0.00%"
                .Range("AE2").Resize(K).NumberFormat = "0.00%"
                .Range("AH2").Resize(K).NumberFormat = "0.00%"
                .SaveAs FileName
            End With
            Wb.Close
            Erase dArr
          
            With Sheet2
                .Rows("1:151").EntireRow.Hidden = False
                .Range("A3:N150").ClearContents
                .Range("A3").Resize(K, 14) = iArr
                .Range("A3:N3").EntireColumn.AutoFit
                .Rows((K + 3) & ":150").EntireRow.Hidden = True
                Set Rng = .Range("A1:N151").SpecialCells(xlCellTypeVisible)
            End With
            Erase iArr
    
            Set OutlookApp = CreateObject("Outlook.Application")
            Set OutlookMail = OutlookApp.CreateItem(0)
            On Error Resume Next
            With OutlookMail
                .To = tArr(I, 4)
                .Cc = tArr(I, 3)
                .Bcc = ""
                .Subject = tArr(I, 5)
                .HTMLBody = tArr(I, 6) & "<br>" & "<br>" & tArr(I, 7) & "<br>"
                .HTMLBody = .HTMLBody & RangetoHTML(Rng)
                .HTMLBody = .HTMLBody & "<br>" & tArr(I, 8)
                .Attachments.Add FileName
                '.Display
                .Send
            End With
            On Error Resume Next
            Set OutlookApp = Nothing: Set OutlookMail = Nothing
        End If
    Next I

    Set Header = Nothing
  
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Ở sheet Nguon bạn liệt kê danh sách email cần gửi.
Mà tôi nghĩ tốt nhất là bạn nên lấy mã nhân viên làm gốc, vì không lo tên giống nhau, tránh nhầm lẫn.

Anh ơi em sữa tiêu đề cột M thành "Ngưng giao dịch >= 6 tháng" và cột N thành "Ngày nhận hàng cuối cùng". Nhờ anh sữa giúp em bảng tổng hợp dán bên dưới khi gửi mail.

 

[vanthinh3101]

Anh ơi em sữa tiêu đề cột M thành "Ngưng giao dịch >= 6 tháng" và cột N thành "Ngày nhận hàng cuối cùng". Nhờ anh sữa giúp em bảng tổng hợp dán bên dưới khi gửi mail.

Gửi lại bạn

Sub SpitFilesAndEmail()
    Dim sArr(), tArr(), dArr(), iArr()
    Dim OutlookApp As Object, OutlookMail As Object
    Dim Wb As Workbook, Header As Range, Rng As Range, FileName As String
    Dim I As Long, J As Long, K As Long, H As Long
      
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    sArr() = Sheet1.Range("A2", Sheet1.Range("A2").End(xlDown)).Resize(, 38).Value
    tArr() = Sheet3.Range("A2", Sheet3.Range("A2").End(xlDown)).Resize(, 8).Value
    Set Header = Sheet1.Range("A1").Resize(, 38)
    'Lay chu ky mac dinh cua Outlook
    Signature = Environ("appdata") & "\Microsoft\Signatures\"
    If Dir(Signature, vbDirectory) <> vbNullString Then
        Signature = Signature & Dir$(Signature & "*.htm")
    Else
        Signature = ""
    End If
    Signature = CreateObject("Scripting.FileSystemObject").GetFile(Signature).OpenAsTextStream(1, -2).ReadAll
    
    For I = 1 To UBound(tArr, 1)
        FileName = ThisWorkbook.Path & "\" & tArr(I, 2) & ".xlsx"
        ReDim dArr(1 To UBound(sArr, 1), 1 To 38)
        ReDim iArr(1 To UBound(sArr, 1), 1 To 14)
        K = 0
        For J = 1 To UBound(sArr, 1)
            If sArr(J, 22) = tArr(I, 2) Then
                K = K + 1
                For H = 1 To 38
                     dArr(K, H) = sArr(J, H)
                Next H
                
                iArr(K, 1) = sArr(J, 3): iArr(K, 2) = sArr(J, 4): iArr(K, 3) = sArr(J, 5)
                For H = 9 To 17
                    iArr(K, H - 5) = sArr(J, H)
                Next H
                iArr(K, 13) = sArr(J, 36): iArr(K, 14) = sArr(J, 37)   'Sua dong nay'
            End If
        Next J
        If K Then
            Set Wb = Workbooks.Add
            With Wb.Worksheets(1)
                Header.Copy .Range("A1")
                .Range("A2").Resize(K, 38) = dArr
                .Range("A1").Resize(, 38).EntireColumn.AutoFit
                .Range("E2:Q2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("Y2:AB2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("AD2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("AF2:AG2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("AL2").Resize(K).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
                .Range("AC2").Resize(K).NumberFormat = "0.00%"
                .Range("AE2").Resize(K).NumberFormat = "0.00%"
                .Range("AH2").Resize(K).NumberFormat = "0.00%"
                .SaveAs FileName
            End With
            Wb.Close
            Erase dArr
            
            With Sheet2
                .Rows("1:151").EntireRow.Hidden = False
                .Range("A3:N150").ClearContents
                .Range("A3").Resize(K, 14) = iArr
                .Range("A3:N3").EntireColumn.AutoFit
                .Rows((K + 3) & ":150").EntireRow.Hidden = True
                Set Rng = .Range("A1:N151").SpecialCells(xlCellTypeVisible)
            End With
            Erase iArr
      
            Set OutlookApp = CreateObject("Outlook.Application")
            Set OutlookMail = OutlookApp.CreateItem(0)
            On Error Resume Next
            With OutlookMail
                .To = tArr(I, 4)
                .Cc = tArr(I, 3)
                .Bcc = ""
                .Subject = tArr(I, 5)
                .HTMLBody = tArr(I, 6) & "<br>" & "<br>" & tArr(I, 7) & "<br>"
                .HTMLBody = .HTMLBody & RangetoHTML(Rng)
                .HTMLBody = .HTMLBody & "<br>" & tArr(I, 8)
                .Attachments.Add FileName
                '.Display
                .Send
            End With
            On Error Resume Next
            Set OutlookApp = Nothing: Set OutlookMail = Nothing
        End If
    Next I
 
    Set Header = Nothing
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Tôi đã đánh dấu dòng sửa

 

[Hanah1994]

Em chào anh chị cao nhân ạ,
Nhờ anh chị giúp em code gửi mail tự động vừa đính kèm file vừa gửi một biểu đồ cụ thể trong file đó ở sheet 1 trong cùng một Email để trình bày biểu đồ ở phần body của mail. Em cám ơn mọi người nhiều ạ.