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

[ronienguyen]

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.

 

[vanthinh3101]

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.

 

[ronienguyen]

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.

 

[vanthinh3101]

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

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.