Nhờ Thầy cô và các anh chị viết code VBA chương trình lọc và tạo danh sách từ nhiều Sheet (1 người xem)

[baquang1984]

Em chào Thầy cô và anh chị trên diễn đàn.
Mong thầy cô và các anh chị trên diễn đàn GPE viết giúp em Code VBA chương trình lọc và tạo danh sách từ nhiều Sheet ạ. Yêu cầu của chương trình như sau:
Khi em Click chuột vào Buttom Tạo danh sách chương trình sẽ lọc dữ liệu từ 2 Sheets đó là Sheets"DaTa_Cu" và Sheets"DaTa_Moi" và tạo danh sách chủ quản lý ở Sheets"Bieu_KQ" điều kiện lọc là theo cột So_CMND1 ở Sheets"DaTa_Moi", Số CMND ở Sheets"DaTa_Cu"
Chương trình tạo lần lượt cho các chủ quản lý có số CMND tương ứng cho đến hết. Dữ liệu được lấy vào bảng ở Sheets"Bieu_KQ" như sau
Cột STT sẽ điền số thứ tự của chủ quản lý
Cột Người sử dụng đất: Dữ liệu được lấy từ Cột CQL của Sheets"DaTa_Moi"
Cột Địa chỉ thường trú: Dữ liệu được lấy từ Cột DIA_CHI1 và cột Xa
- Các cột ở mục "GCNQSD đất cũ" dữ liệu được lấy như sau
+ Cột Số Seri: Lấy từ cột Số Phát hành Sheets"DaTa_Cu
+ Cột Số Tờ bản đồ: Lấy từ cột Tờ bản đồ Sheets"DaTa_Cu
+ Cột Thửa đất số: Lấy từ cột Số thửa Sheets"DaTa_Cũ
+ Cột Diện tích: Lấy từ cột Diện tích Sheets"DaTa_Cu
- Các cột ở mục "GCNQSD đất mới" dữ liệu được lấy như sau
+ Cột Tổng diện tích: Tính tổng diện tích của các thửa lọc được từ cột DienTich Sheets"DaTa_Moi"
+ Cột Số Tờ bản đồ: Lấy từ cột To_BD Sheets"DaTa_Moi"
+ Cột Thửa đất số: Lấy từ cột Shthua Sheets"DaTa_Moi"
+ Cột Diện tích: Lấy từ cột DienTich Sheets"DaTa_Moi"
Kết quả em đã làm mẫu như file đính kèm. Mong nhận được sự giúp đỡ của Thầy cô và anh chị trên diễn đàn ạ
Em cảm ơn nhiều

 

[Hoang2013]

Bạn kiểm theo file

 

[vanthinh3101]

Em chào Thầy cô và anh chị trên diễn đàn.
Mong thầy cô và các anh chị trên diễn đàn GPE viết giúp em Code VBA chương trình lọc và tạo danh sách từ nhiều Sheet ạ. Yêu cầu của chương trình như sau:
Khi em Click chuột vào Buttom Tạo danh sách chương trình sẽ lọc dữ liệu từ 2 Sheets đó là Sheets"DaTa_Cu" và Sheets"DaTa_Moi" và tạo danh sách chủ quản lý ở Sheets"Bieu_KQ" điều kiện lọc là theo cột So_CMND1 ở Sheets"DaTa_Moi", Số CMND ở Sheets"DaTa_Cu"
Chương trình tạo lần lượt cho các chủ quản lý có số CMND tương ứng cho đến hết. Dữ liệu được lấy vào bảng ở Sheets"Bieu_KQ" như sau
Cột STT sẽ điền số thứ tự của chủ quản lý
Cột Người sử dụng đất: Dữ liệu được lấy từ Cột CQL của Sheets"DaTa_Moi"
Cột Địa chỉ thường trú: Dữ liệu được lấy từ Cột DIA_CHI1 và cột Xa
- Các cột ở mục "GCNQSD đất cũ" dữ liệu được lấy như sau
+ Cột Số Seri: Lấy từ cột Số Phát hành Sheets"DaTa_Cu
+ Cột Số Tờ bản đồ: Lấy từ cột Tờ bản đồ Sheets"DaTa_Cu
+ Cột Thửa đất số: Lấy từ cột Số thửa Sheets"DaTa_Cũ
+ Cột Diện tích: Lấy từ cột Diện tích Sheets"DaTa_Cu
- Các cột ở mục "GCNQSD đất mới" dữ liệu được lấy như sau
+ Cột Tổng diện tích: Tính tổng diện tích của các thửa lọc được từ cột DienTich Sheets"DaTa_Moi"
+ Cột Số Tờ bản đồ: Lấy từ cột To_BD Sheets"DaTa_Moi"
+ Cột Thửa đất số: Lấy từ cột Shthua Sheets"DaTa_Moi"
+ Cột Diện tích: Lấy từ cột DienTich Sheets"DaTa_Moi"
Kết quả em đã làm mẫu như file đính kèm. Mong nhận được sự giúp đỡ của Thầy cô và anh chị trên diễn đàn ạ
Em cảm ơn nhiều

Mình thấy bác @Hoang2013 đã trả lời rồi nhưng vẫn muốn góp vui 1 chút.
Ở sheet kết quả, mình thêm 1 dòng lấy số cột.

 

[baquang1984]

Bạn kiểm theo file

Em cảm ơn anh Hoang2013 rất nhiều ạ

 

[baquang1984]

Mình thấy bác @Hoang2013 đã trả lời rồi nhưng vẫn muốn góp vui 1 chút.
Ở sheet kết quả, mình thêm 1 dòng lấy số cột.

Em cảm ơn anh vanthinh3101 tuy nhiên anh có thể sửa giúp em là cái cột điều kiện anh đưa vào dic là cột 2 Sheets"DaTa_Cu" nhưng chương trình em muốn là nó chạy ở cột 4 Sheets"DaTa_Moi"
Anh có thể sửa lại giúp em được không ạ. Em cảm ơn anh nhiều

 

[vanthinh3101]

Em cảm ơn anh vanthinh3101 tuy nhiên anh có thể sửa giúp em là cái cột điều kiện anh đưa vào dic là cột 2 Sheets"DaTa_Cu" nhưng chương trình em muốn là nó chạy ở cột 4 Sheets"DaTa_Moi"
Anh có thể sửa lại giúp em được không ạ. Em cảm ơn anh nhiều

sửa lại 1 chút bạn nhé!

Sub GPE()
    Dim sArr(), tArr(), dArr(), Arr(), Dic As Object
    Dim I As Long, J As Long, K As Long, a As Long, b As Long, lR As Long
    
    Sheet3.Range("A4", Sheet3.Range("F4").End(xlDown)).Resize(, 12).ClearContents
    
    sArr = Sheet1.Range("A2", Sheet1.Range("A2").End(xlDown)).Resize(, 13).Value
    tArr = Sheet2.Range("A2", Sheet2.Range("A2").End(xlDown)).Resize(, 14).Value
        
    Set Dic = CreateObject("Scripting.Dictionary")
    For I = 1 To UBound(tArr, 1)
        If Not Dic.Exists(tArr(I, 4)) Then Dic.Add tArr(I, 4), ""
    Next I
    Arr = Dic.Keys
    For I = 0 To UBound(Arr)
        K = 0: a = 0: b = 0
        ReDim dArr(1 To UBound(sArr, 1), 1 To 12)
        For J = 1 To UBound(sArr, 1)
            If sArr(J, 2) = Val(Arr(I)) Then
                K = K + 1
                dArr(1, 1) = I + 1: dArr(1, 2) = sArr(J, 1): dArr(1, 5) = sArr(J, 4)
                dArr(K, 6) = sArr(J, 8)
                dArr(K, 7) = sArr(J, 9): dArr(K, 8) = sArr(J, 10)
            End If
        Next J
        For J = 1 To UBound(tArr, 1)
            If tArr(J, 4) = Val(Arr(I)) Then
                a = a + 1: b = b + 1
                dArr(1, 3) = tArr(J, 7): dArr(1, 4) = tArr(J, 8)
                dArr(a, 10) = tArr(J, 10): dArr(a, 11) = tArr(J, 9)
                dArr(a, 12) = tArr(J, 12)
                If b = 1 Then
                    dArr(1, 9) = tArr(J, 12)
                Else
                    dArr(1, 9) = dArr(1, 9) + tArr(J, 12)
                End If
            End If
        Next J
        lR = Sheet3.Range("F" & Rows.Count).End(xlUp).Row + 1
        If K > a Then
            Sheet3.Range("A" & lR).Resize(K, 12) = dArr
        Else
            Sheet3.Range("A" & lR).Resize(a, 12) = dArr
        End If
        Erase dArr
    Next I
    Set Dic = Nothing
End Sub

 

[baquang1984]

Option Explicit

Public Sub GPE()
Dim cArr, mArr, dArr, Dic As Object, Tem, X As Long, N As Long, Total
Dim I As Long, K As Long, L As Long, M As Long, R As Long
cArr = Sheet1.Range("A1").CurrentRegion.Value
mArr = Sheet2.Range("A1").CurrentRegion.Value
Set Dic = CreateObject("Scripting.Dictionary")
ReDim dArr(1 To UBound(cArr), 1 To 12)
For I = 2 To UBound(mArr)
Tem = mArr(I, 4)
    If Not Dic.Exists(Tem) Then
        K = K + 1
        Dic.Add Tem, K
        L = 0: X = 0
        For L = 2 To UBound(cArr)
        M = 0
            If cArr(L, 2) = Tem Then
                X = X + 1
                N = N + 1
                If X = 1 Then
                    dArr(N, 1) = K
                    dArr(N, 2) = mArr(I, 1)
                    dArr(N, 3) = mArr(I, 7)
                    dArr(N, 4) = mArr(I, 8)
                End If
                    dArr(N, 5) = cArr(L, 4)
                    dArr(N, 6) = cArr(L, 8)
                    dArr(N, 7) = cArr(L, 9)
                    dArr(N, 8) = cArr(L, 10)
                M = N - 1: Total = 0
                For R = 2 To UBound(mArr)
                    If X = 1 And Tem = mArr(R, 4) Then
                    M = M + 1
                    Total = Total + mArr(R, 12)
                        dArr(N, 9) = Total
                        dArr(M, 10) = mArr(R, 10)
                        dArr(M, 11) = mArr(R, 9)
                        dArr(M, 12) = mArr(R, 12)
                    End If
                Next
            End If
        Next
      
    End If
Next
If N Then
With Sheet3
    .Range("A1").CurrentRegion.Offset(3).ClearContents
    .Range("A3").Resize(N, 12).Value = dArr
    .Range("A3").Resize(N, 12).Borders.LineStyle = 1
End With
End If
Set Dic = Nothing
End Sub

Em cảm ơn bác hpkhuong mấy hôm canh đê hôm nay mới chạy chương trình các bác giúp đỡ. Em xin lỗi cả nhà nhiều

 

[baquang1984]

sửa lại 1 chút bạn nhé!

Sub GPE()
    Dim sArr(), tArr(), dArr(), Arr(), Dic As Object
    Dim I As Long, J As Long, K As Long, a As Long, b As Long, lR As Long
   
    Sheet3.Range("A4", Sheet3.Range("F4").End(xlDown)).Resize(, 12).ClearContents
   
    sArr = Sheet1.Range("A2", Sheet1.Range("A2").End(xlDown)).Resize(, 13).Value
    tArr = Sheet2.Range("A2", Sheet2.Range("A2").End(xlDown)).Resize(, 14).Value
       
    Set Dic = CreateObject("Scripting.Dictionary")
    For I = 1 To UBound(tArr, 1)
        If Not Dic.Exists(tArr(I, 4)) Then Dic.Add tArr(I, 4), ""
    Next I
    Arr = Dic.Keys
    For I = 0 To UBound(Arr)
        K = 0: a = 0: b = 0
        ReDim dArr(1 To UBound(sArr, 1), 1 To 12)
        For J = 1 To UBound(sArr, 1)
            If sArr(J, 2) = Val(Arr(I)) Then
                K = K + 1
                dArr(1, 1) = I + 1: dArr(1, 2) = sArr(J, 1): dArr(1, 5) = sArr(J, 4)
                dArr(K, 6) = sArr(J, 8)
                dArr(K, 7) = sArr(J, 9): dArr(K, 8) = sArr(J, 10)
            End If
        Next J
        For J = 1 To UBound(tArr, 1)
            If tArr(J, 4) = Val(Arr(I)) Then
                a = a + 1: b = b + 1
                dArr(1, 3) = tArr(J, 7): dArr(1, 4) = tArr(J, 8)
                dArr(a, 10) = tArr(J, 10): dArr(a, 11) = tArr(J, 9)
                dArr(a, 12) = tArr(J, 12)
                If b = 1 Then
                    dArr(1, 9) = tArr(J, 12)
                Else
                    dArr(1, 9) = dArr(1, 9) + tArr(J, 12)
                End If
            End If
        Next J
        lR = Sheet3.Range("F" & Rows.Count).End(xlUp).Row + 1
        If K > a Then
            Sheet3.Range("A" & lR).Resize(K, 12) = dArr
        Else
            Sheet3.Range("A" & lR).Resize(a, 12) = dArr
        End If
        Erase dArr
    Next I
    Set Dic = Nothing
End Sub

Em cảm ơn bác vanthinh3101 mấy hôm canh đê hôm nay mới chạy chương trình các bác giúp đỡ. Em xin lỗi cả nhà nhiều