Lấy dữ liệu duy nhất theo từng địa bàn từng danh mục và xuất chi tiết trạm theo địa bàn lần lượt phía dưới

[quyenpv]

Xin chào anh chị!
Mạn phép xin lỗi lại nhờ vả anh chị trên diễn đàn gỡ rối chút ạ. Em có dữ liệu ban đầu tại Sheet CT_BTS có thông tin chi tiết từng loại trong đó em đang muốn lấy dữ liệu các trạm đã quá hạn, còn 3 tháng và 6 tháng để theo dõi. Tuy nhiên code em viết xuất ra Sheet Report toàn bị ghi đè chỉ hiển thị dữ liệu cuối mà em mò mãi không biết sai chỗ nào. Mong anh chị giúp với ạ
Dữ liệu ban đầu

Dữ liệu xuất ra Sheet Report mong muốn

Sub Run_BTS_Report_QHan()

    Dim aTHKI(), aGV(), res(), dic As Object, Wb As Workbook
    Dim Rng As Range, RngFormat As Range, fDay As Date, eDay As Date, tDay As Date
    Dim sRow&, i&, r&, k&, T&, ik&, Diaban$, tmp
    Dim stt&, tR1&, tR2&, fR1&, fR2&, bTd1 As Boolean, bTd2 As Boolean
    Dim lastRow

    'Xoa du lieu hien huu neu co
    Sheets("Report").Select
    With Sheets("Report")
        'Lay Dong cuoi cung cua BQT_VTU
        'Lay dong cuoi cung tai cot Ma Vat tu
        lastRow = .Cells(Rows.Count, "G").End(xlUp).Row
        If lastRow > 8 Then
            'Xoa toan bo bang du lieu hien huu dang co
            .Rows("8:" & lastRow).Delete Shift:=xlShiftUp
        Else
            .Range("A8:K" & lastRow + 1).ClearContents
        End If
    End With
    With Sheets("CT_BTS")
        If .FilterMode Then
            .ShowAllData
        End If
        aGV = .Range("A7:N" & .Range("C" & .Rows.Count).End(xlUp).Row).Value
    End With

    With Sheets("Settings")
        aTHKI = .Range("B4:B" & .Range("B" & .Rows.Count).End(xlUp).Row).Value
    End With

    Set dic = CreateObject("scripting.dictionary")
    sRow = UBound(aTHKI)
    For i = 1 To sRow
        If aTHKI(i, 1) <> Empty Then dic.Item(aTHKI(i, 1)) = i
    Next i
    sRow = UBound(aGV)
    For i = 1 To sRow

        Diaban = aGV(i, 5)    'Dia ban huyen/TP
        If Diaban <> Empty Then
            If aGV(i, 12) <> "" And aGV(i, 12) <= Date Then
                If dic.exists(Diaban & "#") = False Then
                    dic.Add Diaban & "#", ""

                    ReDim res(1 To sRow, 1 To 10)

                    k = 0
                    For r = i To sRow

                        If aGV(r, 5) = Diaban Then
                            If aGV(r, 12) <> "" And aGV(r, 12) <= Date And aGV(r, 13) = ActiveWorkbook.Sheets("Report").Range("L4") Then
                                    k = k + 1
                                    res(k, 1) = k
                                res(k, 2) = aGV(r, 2): res(k, 3) = aGV(r, 3)
                                res(k, 4) = aGV(r, 4): res(k, 5) = aGV(r, 7)

                            End If
                        End If
                    Next r
                    Sheets("Report").Select
                    With Sheets("Report")
                        '.Range("A4") = "BÁO CÁO DANH SÁCH"
                        j = .Cells(Rows.Count, "G").End(xlUp).Row
                        ik = dic.Item(Diaban)
                        If ik > 0 Then
                            .Range("A" & j + 1) = aTHKI(ik, 1)
                            .Range("A" & j + 1).Font.Bold = True
                            .Range("A" & j + 1).HorizontalAlignment = xlLeft
                            .Range("A" & j + 1).WrapText = False
                            .Range("A" & j + 1).Resize(, 10).Interior.Color = RGB(214, 220, 228)
                        End If
                        If k Then
                            .Range("A" & j + 2).Resize(k, 10) = res
                        End If
                    End With
                End If
            End If
        End If
    Next i

End Sub

 

[bebo021999]

Dữ liệu trên sheet Report là kết quả muốn có điền tay đúng không?
Bạn mô tả rõ điều kiện lọc, group nhóm thế nào, cột tình trạng "trễ hạn"ra sao?
Chứ bạn đưa code 1 nùi đọc khó hiểu quá.

 

[quyenpv]

Dữ liệu trên sheet Report là kết quả muốn có điền tay đúng không?
Bạn mô tả rõ điều kiện lọc, group nhóm thế nào, cột tình trạng "trễ hạn"ra sao?
Chứ bạn đưa code 1 nùi đọc khó hiểu quá.

Dạ dữ liệu đó em điền tay và là kết quả mong muốn ạ
Điều kiện lọc là lấy ngày kết thúc hợp đồng bên Sheet CT_BTS so sánh với ngày hiện tại anh. Điều kiện là đưa ra chi tiết từng địa bàn và lần lượt các trạm thuộc địa bàn đó sang Sheet Report ạ

 

[bebo021999]

Dùng thử cái này xem sao:

Option Explicit
Sub test()
Dim lr&, i&, ii&, k&, c&, data, db, res(1 To 100000, 1 To 10), cell As Range
With Sheets("CT_BTS")
    lr = .Cells(Rows.Count, "C").End(xlUp).Row
    data = .Range("A7:M" & lr).Value
End With
db = Sheets("Settings").Range("B4:B11").Value
With Sheets("Report")
    For i = 1 To UBound(db)
        k = k + 1: c = 0: res(k, 1) = db(i, 1)
        For ii = 1 To UBound(data)
            If db(i, 1) = data(ii, 5) And data(ii, 13) = .Range("L4").Value And Date - data(ii, 12) >= 0 Then
                k = k + 1: c = c + 1
                res(k, 1) = c: res(k, 2) = data(ii, 2): res(k, 3) = data(ii, 3): res(k, 4) = data(ii, 4)
                res(k, 5) = data(ii, 7): res(k, 6) = data(ii, 8): res(k, 7) = data(ii, 9): res(k, 8) = data(ii, 12)
                res(k, 9) = .Range("L2").Value & Date - res(k, 8) & .Range("M2").Value
            End If
        Next
    Next
    .Range("A8:J10000").Delete
    .Range("A8:J10000").ClearFormats
    .Range("A8").Resize(k, 10).Value = res
    With .Range("A8").CurrentRegion
        .Borders.LineStyle = xlContinuous
        For Each cell In .Columns(1).Cells
            If cell.Offset(0, 1).Value = "" Then
                cell.Font.Bold = True
                cell.Resize(, 10).Interior.Color = RGB(214, 220, 228)
            End If
        Next
    End With
End With
End Sub

 

[quyenpv]

Dùng thử cái này xem sao:

Option Explicit
Sub test()
Dim lr&, i&, ii&, k&, c&, data, db, res(1 To 100000, 1 To 10), cell As Range
With Sheets("CT_BTS")
    lr = .Cells(Rows.Count, "C").End(xlUp).Row
    data = .Range("A7:M" & lr).Value
End With
db = Sheets("Settings").Range("B4:B11").Value
With Sheets("Report")
    For i = 1 To UBound(db)
        k = k + 1: c = 0: res(k, 1) = db(i, 1)
        For ii = 1 To UBound(data)
            If db(i, 1) = data(ii, 5) And data(ii, 13) = .Range("L4").Value And Date - data(ii, 12) >= 0 Then
                k = k + 1: c = c + 1
                res(k, 1) = c: res(k, 2) = data(ii, 2): res(k, 3) = data(ii, 3): res(k, 4) = data(ii, 4)
                res(k, 5) = data(ii, 7): res(k, 6) = data(ii, 8): res(k, 7) = data(ii, 9): res(k, 8) = data(ii, 12)
                res(k, 9) = .Range("L2").Value & Date - res(k, 8) & .Range("M2").Value
            End If
        Next
    Next
    .Range("A8:J10000").Delete
    .Range("A8:J10000").ClearFormats
    .Range("A8").Resize(k, 10).Value = res
    With .Range("A8").CurrentRegion
        .Borders.LineStyle = xlContinuous
        For Each cell In .Columns(1).Cells
            If cell.Offset(0, 1).Value = "" Then
                cell.Font.Bold = True
                cell.Resize(, 10).Interior.Color = RGB(214, 220, 228)
            End If
        Next
    End With
End With
End Sub

Dạ code chạy đúng rồi ạ, em sẽ test kỹ và báo lại ạ