Lọc và gửi mail theo từng nhân viên

Lê Thị Hoàng Yến · 16/1/19

Kính gửi anh chị,
Mình có 1 file dữ liệu (File đính kèm). Mình muốn gửi mail cho nhân viên nhưng điều kiện là nhân viên đó chỉ xem được data khu vực mình quản lý (Cột B).
Nhưng phải mất công cắt data ra từng nhân viên và gửi mail thì mất rất nhiều thời gian nên nhờ anh chị hỗ trợ giúp mình cách nào đó gửi 1 mail, 1 file data chung nhưng nhân viên nhận mail chỉ xem được data khu vực mình quản lý.
Rất mong anh chị hỗ trợ.
Cảm ơn anh chị

snow25 · 16/1/19

Lê Thị Hoàng Yến đã viết:
Kính gửi anh chị,
Mình có 1 file dữ liệu (File đính kèm). Mình muốn gửi mail cho nhân viên nhưng điều kiện là nhân viên đó chỉ xem được data khu vực mình quản lý (Cột B).
Nhưng phải mất công cắt data ra từng nhân viên và gửi mail thì mất rất nhiều thời gian nên nhờ anh chị hỗ trợ giúp mình cách nào đó gửi 1 mail, 1 file data chung nhưng nhân viên nhận mail chỉ xem được data khu vực mình quản lý.
Rất mong anh chị hỗ trợ.
Cảm ơn anh chị

Bạn sửa lại tiêu đề cho đúng đi.Không thì bị khóa bài bây giờ.Thế bạn gửi mail bằng gmail,hay outlook.

Lê Thị Hoàng Yến · 16/1/19

snow25 đã viết:
Bạn sửa lại tiêu đề cho đúng đi.Không thì bị khóa bài bây giờ.Thế bạn gửi mail bằng gmail,hay outlook.

Gửi Bằng Outlook bạn

befaint · 16/1/19

snow25 đã viết:
gmail,hay outlook.

Gmail là dịch vụ.
MS Outlook là phần mềm.

Lê Thị Hoàng Yến · 17/1/19

befaint đã viết:
Gmail là dịch vụ.
MS Outlook là phần mềm.

Công ty mình sử dụng outlook bạn.

snow25 · 17/1/19

Lê Thị Hoàng Yến đã viết:
Gửi Bằng Outlook bạn

Bạn xem dùng được không nhé.

Mã:

Sub guimail()
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Dim arr, arr1, darr
Dim dk As String, duonglink As String
Dim dic As Object
Dim tong As Worksheet
Dim ws As Workbook
Dim OutApp As Object
Dim OutMail As Object
Dim a As Long, i As Long, lr As Long, j As Long, k As Integer
Dim strPath As String
  'On Error Resume Next
  With CreateObject("Shell.Application")
    strPath = .BrowseForFolder(0, "", 1).Self.Path
  End With
  Set OutApp = CreateObject("Outlook.Application")
      OutApp.Session.Logon
Set tong = ThisWorkbook.Sheets("1.Qty-StoreQ4")
With Sheets("sheet2")
     darr = .Range("A1:b24")
End With
With Sheets("1.Qty-StoreQ4")
     lr = .Range("A" & Rows.Count).End(xlUp).Row
     If lr < 7 Then Exit Sub
     arr = .Range("A7:AX" & lr).Value
End With
    For k = 1 To UBound(darr, 1)
        dk = darr(k, 1): a = 0
        duonglink = strPath & "\" & dk & ".xlsx"
        ReDim arr1(1 To UBound(arr, 1), 1 To UBound(arr, 2))
        For i = 1 To UBound(arr, 1)
            If UCase(arr(i, 1)) = UCase(dk) Then
               a = a + 1
               For j = 1 To UBound(arr, 2)
                   arr1(a, j) = arr(i, j)
               Next j
           End If
       Next i
       Workbooks.Add
       Set ws = ActiveWorkbook
       tong.Cells.Copy ws.Worksheets(1).Range("A1")
       If a Then ws.Sheets(1).Range("A7").Resize(a, UBound(arr, 2)).Value = arr1
       ws.Sheets(1).Range("a" & a + 7).Resize(10000, UBound(arr, 2)).Clear
       ws.Close True, duonglink
        Set OutMail = OutApp.CreateItem(0)
          With OutMail
               .To = darr(k, 2)   'dia chi gui thu
               .Subject = "XIN CHAO "   'thong tin
               .Attachments.Add duonglink   'thu muc can gui
               .display               'xem thu gui di
           End With
     Next k
      Set OutMail = Nothing
      Set OutApp = Nothing
  Application.ScreenUpdating = True
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
End Sub

Quang_Hải · 17/1/19

Lê Thị Hoàng Yến đã viết:
Kính gửi anh chị,
Mình có 1 file dữ liệu (File đính kèm). Mình muốn gửi mail cho nhân viên nhưng điều kiện là nhân viên đó chỉ xem được data khu vực mình quản lý (Cột B).
Nhưng phải mất công cắt data ra từng nhân viên và gửi mail thì mất rất nhiều thời gian nên nhờ anh chị hỗ trợ giúp mình cách nào đó gửi 1 mail, 1 file data chung nhưng nhân viên nhận mail chỉ xem được data khu vực mình quản lý.
Rất mong anh chị hỗ trợ.
Cảm ơn anh chị

Bạn thử sử dụng đoạn code sau nhé.
Những lưu ý cần có khi sử dụng file

1. Tên nhân viên trong sheet email phải trùng khớp với tên nhân viên trong sheet tổng ( kể cả những khoảng cách)
2. Tên nhân viên bắt buộc phải tồn tại trong sheet email nếu không có sẽ gây ra lỗi
3. Bạn có thể sửa lại nội dung thông tin từ phần dòng code .Subject = .....
4. Nội dung điều chỉnh phải luôn trong dấu nháy

Mã:

Sub Send_Mail()
Dim item, MyRange As Range, i As Long, TieuDe As Range, tmp As String
Dim dArr(), sArr(), Dic As Object, k As Long, j As Long, email As String
Set Dic = CreateObject("scripting.dictionary")
With Sheets("1.Qty-StoreQ4")
   sArr = .Range("A7", .[A65536].End(3)).Resize(, 47).Value
   Set TieuDe = .[A1:AU6]
End With
ReDim dArr(1 To UBound(sArr), 1 To UBound(sArr, 2))
For i = 1 To UBound(sArr)
   If sArr(i, 2) <> Empty Then
      tmp = LCase(sArr(i, 2))
      Dic(tmp) = Empty
   End If
Next
For Each item In Dic.keys
   k = 0
   For i = 1 To UBound(sArr)
      If sArr(i, 2) <> Empty Then
         tmp = LCase(sArr(i, 2))
         If tmp = item Then
            k = k + 1
            For j = 1 To UBound(sArr, 2)
               dArr(k, j) = sArr(i, j)
            Next
         End If
      End If
   Next
   email = Sheets("email").[a:a].Find(tmp, , , 1).Offset(, 1)
   With Workbooks.Add
      .ActiveSheet.[A7].Resize(k, UBound(dArr, 2)) = dArr
      TieuDe.Copy .ActiveSheet.[A1]
      .SaveAs ThisWorkbook.Path & "\" & tmp & ".xlsx"
      .Close
   End With
   With CreateObject("Outlook.Application")
      .Session.Logon
         With .CreateItem(0)
         .to = email
         .Subject = "Thong tin tieu de"
         .Body = "Kinh goi anh (chi) " & vbNewLine & vbNewLine _
         & "noi dung dong 1" & vbNewLine _
         & "noi dung dong 2" & vbNewLine _
         & "noi dung dong 3" & vbNewLine _
         & "noi dung dong 4" & vbNewLine & vbNewLine _
         & "Tran Trong" & vbNewLine & vbNewLine _
         & "Le Thi Hoang Yen"
         .Attachments.Add ThisWorkbook.Path & "\" & tmp & ".xlsx"
        .Display
      End With
   End With
   With CreateObject("scripting.FileSystemObject")
      .DeleteFile ThisWorkbook.Path & "\" & tmp & ".xlsx"
   End With
Next
End Sub

Lê Thị Hoàng Yến · 17/1/19

quanghai1969 đã viết:

Bạn thử sử dụng đoạn code sau nhé.
Những lưu ý cần có khi sử dụng file

1. Tên nhân viên trong sheet email phải trùng khớp với tên nhân viên trong sheet tổng ( kể cả những khoảng cách)
2. Tên nhân viên bắt buộc phải tồn tại trong sheet email nếu không có sẽ gây ra lỗi
3. Bạn có thể sửa lại nội dung thông tin từ phần dòng code .Subject = .....
4. Nội dung điều chỉnh phải luôn trong dấu nháy

Mã:

Sub Send_Mail()
Dim item, MyRange As Range, i As Long, TieuDe As Range, tmp As String
Dim dArr(), sArr(), Dic As Object, k As Long, j As Long, email As String
Set Dic = CreateObject("scripting.dictionary")
With Sheets("1.Qty-StoreQ4")
   sArr = .Range("A7", .[A65536].End(3)).Resize(, 47).Value
   Set TieuDe = .[A1:AU6]
End With
ReDim dArr(1 To UBound(sArr), 1 To UBound(sArr, 2))
For i = 1 To UBound(sArr)
   If sArr(i, 2) <> Empty Then
      tmp = LCase(sArr(i, 2))
      Dic(tmp) = Empty
   End If
Next
For Each item In Dic.keys
   k = 0
   For i = 1 To UBound(sArr)
      If sArr(i, 2) <> Empty Then
         tmp = LCase(sArr(i, 2))
         If tmp = item Then
            k = k + 1
            For j = 1 To UBound(sArr, 2)
               dArr(k, j) = sArr(i, j)
            Next
         End If
      End If
   Next
   email = Sheets("email").[a:a].Find(tmp, , , 1).Offset(, 1)
   With Workbooks.Add
      .ActiveSheet.[A7].Resize(k, UBound(dArr, 2)) = dArr
      TieuDe.Copy .ActiveSheet.[A1]
      .SaveAs ThisWorkbook.Path & "\" & tmp & ".xlsx"
      .Close
   End With
   With CreateObject("Outlook.Application")
      .Session.Logon
         With .CreateItem(0)
         .to = email
         .Subject = "Thong tin tieu de"
         .Body = "Kinh goi anh (chi) " & vbNewLine & vbNewLine _
         & "noi dung dong 1" & vbNewLine _
         & "noi dung dong 2" & vbNewLine _
         & "noi dung dong 3" & vbNewLine _
         & "noi dung dong 4" & vbNewLine & vbNewLine _
         & "Tran Trong" & vbNewLine & vbNewLine _
         & "Le Thi Hoang Yen"
         .Attachments.Add ThisWorkbook.Path & "\" & tmp & ".xlsx"
        .Display
      End With
   End With
   With CreateObject("scripting.FileSystemObject")
      .DeleteFile ThisWorkbook.Path & "\" & tmp & ".xlsx"
   End With
Next
End Sub

Cảm ơn bạn rất nhiều !

Bài đã được tự động gộp: 17/1/19

snow25 đã viết:

Bạn xem dùng được không nhé.

Mã:

Sub guimail()
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Dim arr, arr1, darr
Dim dk As String, duonglink As String
Dim dic As Object
Dim tong As Worksheet
Dim ws As Workbook
Dim OutApp As Object
Dim OutMail As Object
Dim a As Long, i As Long, lr As Long, j As Long, k As Integer
Dim strPath As String
  'On Error Resume Next
  With CreateObject("Shell.Application")
    strPath = .BrowseForFolder(0, "", 1).Self.Path
  End With
  Set OutApp = CreateObject("Outlook.Application")
      OutApp.Session.Logon
Set tong = ThisWorkbook.Sheets("1.Qty-StoreQ4")
With Sheets("sheet2")
     darr = .Range("A1:b24")
End With
With Sheets("1.Qty-StoreQ4")
     lr = .Range("A" & Rows.Count).End(xlUp).Row
     If lr < 7 Then Exit Sub
     arr = .Range("A7:AX" & lr).Value
End With
    For k = 1 To UBound(darr, 1)
        dk = darr(k, 1): a = 0
        duonglink = strPath & "\" & dk & ".xlsx"
        ReDim arr1(1 To UBound(arr, 1), 1 To UBound(arr, 2))
        For i = 1 To UBound(arr, 1)
            If UCase(arr(i, 1)) = UCase(dk) Then
               a = a + 1
               For j = 1 To UBound(arr, 2)
                   arr1(a, j) = arr(i, j)
               Next j
           End If
       Next i
       Workbooks.Add
       Set ws = ActiveWorkbook
       tong.Cells.Copy ws.Worksheets(1).Range("A1")
       If a Then ws.Sheets(1).Range("A7").Resize(a, UBound(arr, 2)).Value = arr1
       ws.Sheets(1).Range("a" & a + 7).Resize(10000, UBound(arr, 2)).Clear
       ws.Close True, duonglink
        Set OutMail = OutApp.CreateItem(0)
          With OutMail
               .To = darr(k, 2)   'dia chi gui thu
               .Subject = "XIN CHAO "   'thong tin
               .Attachments.Add duonglink   'thu muc can gui
               .display               'xem thu gui di
           End With
     Next k
      Set OutMail = Nothing
      Set OutApp = Nothing
  Application.ScreenUpdating = True
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
End Sub

Cảm ơn bạn nhiều!

Lọc và gửi mail theo từng nhân viên

Lê Thị Hoàng Yến

Thành viên mới

File đính kèm

snow25

Thành viên gạo cội

Lê Thị Hoàng Yến

Thành viên mới

befaint

|||||||||||||

Lê Thị Hoàng Yến

Thành viên mới

snow25

Thành viên gạo cội

File đính kèm

Quang_Hải

Thành viên gạo cội

File đính kèm

Lê Thị Hoàng Yến

Thành viên mới

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian