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

ronienguyen

Thành viên mới
Tham gia ngày
7 Tháng tư 2017
Bài viết
2
Thích
0
Điểm
0
#1
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

vanthinh3101

Thành viên tiêu biểu
Tham gia ngày
24 Tháng một 2015
Bài viết
655
Thích
631
Điểm
360
Tuổi
30
#2
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

ronienguyen

Thành viên mới
Tham gia ngày
7 Tháng tư 2017
Bài viết
2
Thích
0
Điểm
0
#3
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

Thành viên tiêu biểu
Tham gia ngày
24 Tháng một 2015
Bài viết
655
Thích
631
Điểm
360
Tuổi
30
#4
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.
 
Top