Giúp đỡ Tách File có điều kiện bằng VBA

[anh1234]

Dear Các Bác
Em có bài toán này mà chưa biết giải quyết ra sao, kính nhờ các cao thủ giúp đỡ
Em có File 1 file excel dùng lượng lớn khoảng: 45 cột và 100.000 dòng ( Sheet DATA)
Yêu cầu là tách tất cả các dòng có khách hàng có thõa mãn điều kiện 1 khách hàng có nhiều hơn 2 loại bệnh ra file mới ( Sheet KET QUA)
Bình thường em dùng PIVOT tìm được các Khách hàng theo cột mã bệnh nhân có nhiều loại bệnh, sau đó vlookup ngược lại DATA theo mã bênh nhân. Được DS tất cả các dòng có khách hàng ( mã bênh nhân)thỏa mãn điều kiện: Có 2, nhiều hơn 2 loại bệnh. >> Đó chính là File mong muốn.
Kính nhờ các bác code VBA giúp em để em không cần phải dùng PIVOT nữa ạ
File đính kèm của em:
Sheet DATA: dữ liệu gốc, Sheet PIVOT: Cách thức em thường làm để kết quả
Sheet KETQUA: là file kết quả em muốn tách ( Lấy hết các dòng chứa mã bệnh nhân thỏa mãn: mã bênh nhân tồn tại ít nhất 2 nhóm bệnh: nhiều hơn hoặc bằng 2 nhóm bệnh)
Ví dụ: mã 0100680618, khách hàng A tồn tại 3 loại bênh A,B,C Copy toàn bộ các dòng của mã 0100680618 ra file Ket quả
Mã 0100086186, Khách hàng A2599 tồn tại 2 loại bênh D và E, copy toàn bộ các dòng của mã 0100086186 ra file Kêt quả
Các khách hàng xuất hiện nhiều dòng, nhưng chỉ có 1 loại bệnh thì ko cần copy ra.
Khi đó File kết quả gồm tất cả các dòng của 2 mã KH:0100086186 và 0100680618.

Em cám ơn các Bác.

 

[vanthinh3101]

Dear Các Bác
Em có bài toán này mà chưa biết giải quyết ra sao, kính nhờ các cao thủ giúp đỡ
Em có File 1 file excel dùng lượng lớn khoảng: 45 cột và 100.000 dòng ( Sheet DATA)
Yêu cầu là tách tất cả các dòng có khách hàng có thõa mãn điều kiện 1 khách hàng có nhiều hơn 2 loại bệnh ra file mới ( Sheet KET QUA)
Bình thường em dùng PIVOT tìm được các Khách hàng theo cột mã bệnh nhân có nhiều loại bệnh, sau đó vlookup ngược lại DATA theo mã bênh nhân. Được DS tất cả các dòng có khách hàng ( mã bênh nhân)thỏa mãn điều kiện: Có 2, nhiều hơn 2 loại bệnh. >> Đó chính là File mong muốn.
Kính nhờ các bác code VBA giúp em để em không cần phải dùng PIVOT nữa ạ
File đính kèm của em:
Sheet DATA: dữ liệu gốc, Sheet PIVOT: Cách thức em thường làm để kết quả
Sheet KETQUA: là file kết quả em muốn tách ( Lấy hết các dòng chứa mã bệnh nhân thỏa mãn: mã bênh nhân tồn tại ít nhất 2 nhóm bệnh: nhiều hơn hoặc bằng 2 nhóm bệnh)
Ví dụ: mã 0100680618, khách hàng A tồn tại 3 loại bênh A,B,C Copy toàn bộ các dòng của mã 0100680618 ra file Ket quả
Mã 0100086186, Khách hàng A2599 tồn tại 2 loại bênh D và E, copy toàn bộ các dòng của mã 0100086186 ra file Kêt quả
Các khách hàng xuất hiện nhiều dòng, nhưng chỉ có 1 loại bệnh thì ko cần copy ra.
Khi đó File kết quả gồm tất cả các dòng của 2 mã KH:0100086186 và 0100680618.

Em cám ơn các Bác.

Bạn dùng code sau:

Sub GPE()
    Dim Dic As Object, sArr(), Temp(), Res()
    Dim I As Long, J As Long, K As Long, H As Long
    
    Application.ScreenUpdating = False
    Set Dic = CreateObject("Scripting.Dictionary")
    sArr() = Sheet2.Range("A2", Sheet2.Range("A2").End(xlDown)).Resize(, 37).Value
    ReDim Temp(1 To UBound(sArr, 1), 1 To UBound(sArr, 2))
    ReDim Res(1 To UBound(sArr, 1), 1 To UBound(sArr, 2))
    
    For I = 1 To UBound(sArr, 1)
        If Not Dic.exists(sArr(I, 6)) Then
            K = K + 1: Dic.Add sArr(I, 6), K & "|" & sArr(I, 14)
            Temp(K, 1) = sArr(I, 6): Temp(K, 2) = 1
        Else
            If Split(Dic.Item(sArr(I, 6)), "|")(1) <> sArr(I, 14) Then
                Temp(Split(Dic.Item(sArr(I, 6)), "|")(0), 2) = Temp(Split(Dic.Item(sArr(I, 6)), "|")(0), 2) + 1
            End If
        End If
    Next I
    
    K = 0
    For J = 1 To UBound(Temp, 1)
        If Temp(J, 2) > 1 Then
            For I = 1 To UBound(sArr, 1)
                If Temp(J, 1) = sArr(I, 6) Then
                    K = K + 1
                    For H = 1 To UBound(sArr, 2)
                        Res(K, H) = sArr(I, H)
                    Next H
                End If
            Next I
        End If
    Next J
    
    If K Then
        Sheet3.Range("A2").CurrentRegion.Offset(1).ClearContents
        Sheet3.Range("A2").Resize(K, UBound(sArr, 2)) = Res
    End If
    
    Set Dic = Nothing
    Application.ScreenUpdating = True
    
    MsgBox "Done", vbInformation, "GPE"
End Sub

Chúc bạn thành công.

 

[anh1234]

Bạn dùng code sau:

Sub GPE()
    Dim Dic As Object, sArr(), Temp(), Res()
    Dim I As Long, J As Long, K As Long, H As Long

    Application.ScreenUpdating = False
    Set Dic = CreateObject("Scripting.Dictionary")
    sArr() = Sheet2.Range("A2", Sheet2.Range("A2").End(xlDown)).Resize(, 37).Value
    ReDim Temp(1 To UBound(sArr, 1), 1 To UBound(sArr, 2))
    ReDim Res(1 To UBound(sArr, 1), 1 To UBound(sArr, 2))

    For I = 1 To UBound(sArr, 1)
        If Not Dic.exists(sArr(I, 6)) Then
            K = K + 1: Dic.Add sArr(I, 6), K & "|" & sArr(I, 14)
            Temp(K, 1) = sArr(I, 6): Temp(K, 2) = 1
        Else
            If Split(Dic.Item(sArr(I, 6)), "|")(1) <> sArr(I, 14) Then
                Temp(Split(Dic.Item(sArr(I, 6)), "|")(0), 2) = Temp(Split(Dic.Item(sArr(I, 6)), "|")(0), 2) + 1
            End If
        End If
    Next I

    K = 0
    For J = 1 To UBound(Temp, 1)
        If Temp(J, 2) > 1 Then
            For I = 1 To UBound(sArr, 1)
                If Temp(J, 1) = sArr(I, 6) Then
                    K = K + 1
                    For H = 1 To UBound(sArr, 2)
                        Res(K, H) = sArr(I, H)
                    Next H
                End If
            Next I
        End If
    Next J

    If K Then
        Sheet3.Range("A2").CurrentRegion.Offset(1).ClearContents
        Sheet3.Range("A2").Resize(K, UBound(sArr, 2)) = Res
    End If

    Set Dic = Nothing
    Application.ScreenUpdating = True

    MsgBox "Done", vbInformation, "GPE"
End Sub

Chúc bạn thành công.

Tuy nhiên, vì mã bênh nhân và 1 cột có dữ liệu số mã có dạng 0100115646 ( 10 ký tự)khi copy ra sheet KET QUA bị mất số 0 ở đầu còn 100115646(9 ký tự).
Bác sửa bổ sung thêm giúp em 1 chút ạ
1.Khi tách ra sheet KET QUA giữ nguyên format như sheet DATA
2.Tách ra sheet KETQUA thì copy cả dòng tiêu đề ạ.
3. Lỗi 7: out of memory ạ

EM cám ơn bác nhiều. Chúc bác năm mới SỨC KHOE và THANH CONG.

 

[vanthinh3101]

Tuy nhiên, vì mã bênh nhân và 1 cột có dữ liệu số mã có dạng 0100115646 ( 10 ký tự)khi copy ra sheet KET QUA bị mất số 0 ở đầu còn 100115646(9 ký tự).
Bác sửa bổ sung thêm giúp em 1 chút ạ
1.Khi tách ra sheet KET QUA giữ nguyên format như sheet DATA
2.Tách ra sheet KETQUA thì copy cả dòng tiêu đề ạ.
3. Lỗi 7: out of memory ạ

EM cám ơn bác nhiều. Chúc bác năm mới SỨC KHOE và THANH CONG.

Đối với 1 và 2:
- Ở sheet Kết quả, bạn nên có sẵn dòng tiêu đề.
- Ngoài ra, bạn cần xác định rõ cột nào định dạng ra sao để format sẵn. Ví dụ: cột F định dạng sẵn là Text,...
Đối với 3:
Lỗi 7: out of memory --> có thể do mảng của bạn có kích thước vượt quá bộ nhớ của máy tính (RAM). Bạn đọc loạt bài ở trang 43 này nhé.
http://www.giaiphapexcel.com/dienda...ảng-trong-vba-array.46834/page-43#post-799810

 

[Phuocam]

1.Khi tách ra sheet KET QUA giữ nguyên format như sheet DATA

Dùng advanced Filter, kết quả giữ nguyên format như sheet DATA.