VBA tách dữ liệu từ 1 file tổng ra thành từng file theo điều kiện đơn vị

Liên hệ QC

ronienguyen

Thành viên mới
Tham gia
7/4/17
Bài viết
2
Được thích
0
Em có 1 file tổng hợp theo file đính kèm (em sưu tầm trên mạng), VBA của file thao tác filter theo đơn vị và sau đó copy vào 1 file khác (vẫn còn filter và danh sách vẫn còn) và gửi mail cho đơn vị theo danh sách.
Nhưng giờ em muốn thay đổi là copy dữ liệu ra 1 file khác chỉ có dữ liệu của 1 đơn vị và gửi mail đi.
Em mò và thay đổi code nhưng vẫn không được.
Nhờ các bậc tiền bối hỗ trợ giúp em ah.
Em xin cảm ơn nhiều nhiều.
 

File đính kèm

  • Auto_Filter_Send_Email.xlsm
    34 KB · Đọc: 11
Em có 1 file tổng hợp theo file đính kèm (em sưu tầm trên mạng), VBA của file thao tác filter theo đơn vị và sau đó copy vào 1 file khác (vẫn còn filter và danh sách vẫn còn) và gửi mail cho đơn vị theo danh sách.
Nhưng giờ em muốn thay đổi là copy dữ liệu ra 1 file khác chỉ có dữ liệu của 1 đơn vị và gửi mail đi.
Em mò và thay đổi code nhưng vẫn không được.
Nhờ các bậc tiền bối hỗ trợ giúp em ah.
Em xin cảm ơn nhiều nhiều.
Bạn xem file, mình có điều chỉnh file 1 chút.
Mình cũng chưa viết code gửi email để dùng thực tế lần nào.
 

File đính kèm

  • Auto_Filter_Send_Email.xlsm
    34.4 KB · Đọc: 15
Cảm ơn vanthinh3101 nhiều. Khi mình chạy macro thì chỉ lấy được 1 dữ liệu ban đầu, ví dụ như đơn vị 4 có 3 dòng dữ liệu nhưng khi chạy chỉ lấy được dữ liệu ban đầu. Bạn có cách nào lấy được luôn 2 dòng dữ liệu còn lại không.
 
Cảm ơn vanthinh3101 nhiều. Khi mình chạy macro thì chỉ lấy được 1 dữ liệu ban đầu, ví dụ như đơn vị 4 có 3 dòng dữ liệu nhưng khi chạy chỉ lấy được dữ liệu ban đầu. Bạn có cách nào lấy được luôn 2 dòng dữ liệu còn lại không.
Sơ suất quá, mình không check lại trước khi gửi bạn.
Mình gửi lại bạn code
Mã:
Sub SpitFilesAndEmail()
    Dim sArr(), tArr(), dArr()
    Dim OutlookApp As Object, OutlookMail As Object
    Dim Wb As Workbook, Header As Range, FileName As String
    Dim I As Long, J As Long, K As Long, H As Long
       
    sArr() = Sheet3.Range("A2", Sheet3.Range("A2").End(xlDown)).Resize(, 3).Value
    tArr() = Sheet2.Range("B5", Sheet2.Range("B5").End(xlDown)).Resize(, 12).Value
    Set Header = Sheet2.Range("B4").Resize(, 12)
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
   
    For I = 1 To UBound(sArr, 1)
        FileName = ThisWorkbook.Path & "\Bang tong hop don vi " & sArr(I, 1) & ".xlsx"
        ReDim dArr(1 To UBound(tArr, 1), 1 To 12)
        K = 0
        For J = 1 To UBound(tArr, 1)
            If tArr(J, 1) = sArr(I, 1) Then
                K = K + 1
                For H = 1 To 12
                     dArr(K, H) = tArr(J, H)
                Next H
            End If
        Next J
        If K Then
            Set Wb = Workbooks.Add
            With Wb
                Header.Copy .Worksheets(1).Range("B4")
                .Worksheets(1).Range("B5").Resize(K, 12) = dArr
                .Worksheets(1).Range("B5").Resize(, 12).EntireColumn.AutoFit
                .SaveAs FileName
                .Close
            End With
            Erase dArr
       
            On Error Resume Next
            With OutlookMail
                .To = sArr(I, 2)
                .Cc = sArr(I, 3)
                .Bcc = ""
                .Subject = Sheet3.Range("G1") & sArr(I, 1)
                .htmlBody = Sheet3.Range("G2")
                .Attachments.Add FileName
                .Send
            End With
            On Error Resume Next
        End If
    Next I
   
    Set Header = Nothing
    Set OutlookApp = Nothing
    Set OutlookMail = Nothing
End Sub
Thêm K ở dòng .Worksheets(1).Range("B5").Resize(K, 12) = dArr
Chúc bạn thành công.
 
Web KT
Back
Top Bottom