Giúp em code kiểm tra cửa hàng nào đã báo cáo số liệu và mặt hàng đã báo cáo

[nhnn1986]

Chào Anh/Chị ạ, em có bài toán thế này:

Hàng tuần em phải tổng hợp số lượng cửa hàng tạp hóa báo cáo số liệu mua bán và các mặt hàng mua bán được trong tuần.
Số lượng cửa hàng có mới, có cũ, không hợp tác nữa nên biến động hàng tuần; Mặt hàng bán cũng biến động do hàng mới, hàng mẫu mã cũ không bán nữa v.v.v

Tên file các cửa hàng gửi về có dạng: 1xxxxx-yyyyyyyy-1zzzzzzz-aa-b-cc.xlsx (6 ký tự xxxxxx là mã cửa hàng, 8 ký tự zzzzzzzz là mã sản phẩm)
Các file báo cáo các cửa hàng em để chung vào 1 folder và kiếm được code để lấy tên file báo cáo vào Cột A, vấn đề của em là từ "Cột A: Tên file báo cáo" này kiểm tra xem cửa hàng nào đã gửi số liệu và đã gửi những mặt hàng nào rồi.

Em nhờ Anh/Chị viết giùm em đoạn code để kiểm tra như sau:
=> Nếu mà cửa hàng đã báo cáo mặt hàng nào đó rồi thì ô tương ứng "YES" và bôi màu xanh
=> Nếu mà cửa hàng chưa báo cáo mặt hàng nào đó thì ô tương ứng "NO" và bôi màu đỏ
Từ B2:Bi là mã các cửa hàng, còn C3:Cj là mã các mặt hàng
Em gửi kèm file mẫu để Anh/Chị dễ hình dung ạ. Em cảm ơn trước ạ

 

[leonguyenz]

Có thể làm công thức và CF không?
C2:

=IF(COUNTIF($A$2:$A$10,"*"&$B2&"*"&C$1&"*"),"YES","NO")

 

[Hoàng Nhật Phương]

Có thể làm công thức và CF không?
C2:

=IF(COUNTIF($A$2:$A$10,"*"&$B2&"*"&C$1&"*"),"YES","NO")

Chắc là không Anh ạ, vì đây là box lập trình , hóng Anh leonguyenz tiếp tục

 

[nhnn1986]

Dạ thực tế thì làm công thức xong Yes,No sau đó condittions format là ra màu theo ý. Em cũng thử rồi nhưng xét thấy làm code VBA đỡ lằng nhằng chỉnh sửa hơn ạ hi hi

 

[leonguyenz]

Chắc là không Anh ạ, vì đây là box lập trình , hóng Anh leonguyenz tiếp tục

Duyệt 2 vòng lặp dòng/cột rồi lặp thêm 1 vòng cột A kiểm tra chuỗi con (khách hàng & sản phẩm) trong chuỗi mẹ, OT thử xem.

 

[Hoàng Nhật Phương]

Duyệt 2 vòng lặp dòng/cột rồi lặp thêm 1 vòng cột A kiểm tra chuỗi con (khách hàng & sản phẩm) trong chuỗi mẹ, OT thử xem.

Cảm ơn Anh leonguyenz nhiều ạ.
Theo gợi ý , chỉ dẫn của Anh leonguyenz, OT xin phép ạ:

Option Explicit

Sub KiemTra()
    Dim lA As Long, lB As Long, lC As Long, i As Long, j As Long, k As Long
    With Sheets("Kiem_tra")
        lA = .Cells(.Rows.Count, "A").End(xlUp).Row
        lB = .Cells(.Rows.Count, "B").End(xlUp).Row
        lC = .Cells(1, 255).End(xlToLeft).Column
        For i = 2 To lB
            For j = 3 To lC
                .Cells(i, j) = "No"
                .Cells(i, j).Font.ColorIndex = 3
                k = 1
                Do While k <= lA
                    k = k + 1
                    If Left(.Cells(k, 1), 6) & Mid(.Cells(k, 1), 17, 8) = .Cells(i, 2) & .Cells(1, j) Then
                        .Cells(i, j) = "Yes"
                        .Cells(i, j).Font.ColorIndex = 5
                        Exit Do
                    End If
                Loop
            Next j
        Next i
    End With
End Sub

Sub TestColor()
    Dim i As Integer
    For i = 1 To 56
        With Sheets("Kiem_tra").Cells(i, 13)
            .Interior.ColorIndex = i
            .Font.ColorIndex = i
        End With
    Next i
End Sub

 

[nhnn1986]

Thanks Ms OT mà code chạy hơi chậm có lẽ do duyệt từng dòng. Nên với số mẫu em gửi thì nhanh mà đến 200 dòng (tương đương 200 cửa hàng) và tầm 50 cột (tương đương 50 mã hàng) thì bị "Not responding" mất gần 2 phút ạ hic.

Em cũng đang nghiên cứu thêm về code làm bài toán này theo mảng array có lẽ nhanh hơn hi hi.
Anh/Chị giúp em lần nữa ạ

 

[snow25]

Cảm ơn Ms OT mà code chạy hơi chậm có lẽ do duyệt từng dòng. Nên với số mẫu em gửi thì nhanh mà đến 200 dòng (tương đương 200 cửa hàng) và tầm 50 cột (tương đương 50 mã hàng) thì bị "Not responding" mất gần 2 phút ạ hic.

Em cũng đang nghiên cứu thêm về code làm bài toán này theo mảng array có lẽ nhanh hơn hi hi.
Anh/Chị giúp em lần nữa ạ

Bạn chạy code này xem.

Sub linhtinh()
    Dim arr, dic As Object, i As Long, j As Long, lr As Long, dk As String
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("Kiem_tra")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:A" & lr).Value
         For i = 1 To UBound(arr, 1)
             dk = Left(arr(i, 1), 6) & "#" & Mid(arr(i, 1), 17, 8)
             If Not dic.exists(dk) Then
                dic.Add dk, ""
             End If
         Next i
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr = 1 Then Exit Sub
         .Range("C2:K" & lr).ClearContents
         arr = .Range("B1:K" & lr).Value
         For i = 2 To UBound(arr, 1)
             For j = 2 To UBound(arr, 2)
                  dk = arr(i, 1) & "#" & arr(1, j)
                  If dic.exists(dk) Then
                     arr(i, j) = "YES"
                      .Cells(i, j + 1).Font.ColorIndex = 5
                  Else
                     arr(i, j) = "NO"
                     .Cells(i, j + 1).Font.ColorIndex = 3
                  End If
             Next j
        Next i
        .Range("B1:K" & lr).Value = arr
  End With
End Sub

Bài đã được tự động gộp: 6/5/19

Cảm ơn Anh leonguyenz nhiều ạ.
Theo gợi ý , chỉ dẫn của Anh leonguyenz, OT xin phép ạ:

Option Explicit

Sub KiemTra()
    Dim lA As Long, lB As Long, lC As Long, i As Long, j As Long, k As Long
    With Sheets("Kiem_tra")
        lA = .Cells(.Rows.Count, "A").End(xlUp).Row
        lB = .Cells(.Rows.Count, "B").End(xlUp).Row
        lC = .Cells(1, 255).End(xlToLeft).Column
        For i = 2 To lB
            For j = 3 To lC
                .Cells(i, j) = "No"
                .Cells(i, j).Font.ColorIndex = 3
                k = 1
                Do While k <= lA
                    k = k + 1
                    If Left(.Cells(k, 1), 6) & Mid(.Cells(k, 1), 17, 8) = .Cells(i, 2) & .Cells(1, j) Then
                        .Cells(i, j) = "Yes"
                        .Cells(i, j).Font.ColorIndex = 5
                        Exit Do
                    End If
                Loop
            Next j
        Next i
    End With
End Sub

Sub TestColor()
    Dim i As Integer
    For i = 1 To 56
        With Sheets("Kiem_tra").Cells(i, 13)
            .Interior.ColorIndex = i
            .Font.ColorIndex = i
        End With
    Next i
End Sub

Sao bạn không dùng Dictionary cho nhanh.Sao phải chạy vòng lặp không xác định này.

 

[Hoàng Nhật Phương]

Bạn chạy code này xem.

Sub linhtinh()
    Dim arr, dic As Object, i As Long, j As Long, lr As Long, dk As String
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("Kiem_tra")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:A" & lr).Value
         For i = 1 To UBound(arr, 1)
             dk = Left(arr(i, 1), 6) & "#" & Mid(arr(i, 1), 17, 8)
             If Not dic.exists(dk) Then
                dic.Add dk, ""
             End If
         Next i
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr = 1 Then Exit Sub
         .Range("C2:K" & lr).ClearContents
         arr = .Range("B1:K" & lr).Value
         For i = 2 To UBound(arr, 1)
             For j = 2 To UBound(arr, 2)
                  dk = arr(i, 1) & "#" & arr(1, j)
                  If dic.exists(dk) Then
                     arr(i, j) = "YES"
                      .Cells(i, j + 1).Font.ColorIndex = 5
                  Else
                     arr(i, j) = "NO"
                     .Cells(i, j + 1).Font.ColorIndex = 3
                  End If
             Next j
        Next i
        .Range("B1:K" & lr).Value = arr
  End With
End Sub

Bài đã được tự động gộp: 6/5/19

Sao bạn không dùng Dictionary cho nhanh.Sao phải chạy vòng lặp không xác định này.

Cảm ơn Snow25 đã chỉ cho OT thêm một cách để tham khảo.
Mới đầu OT cũng đã có ý định dùng Dic (và đã code với Dic rồi) nhưng code vẫn còn linh tinh không thể ra được kết quả gi mẫu nên theo gợi ý của Anh leonguyenz, OT chuyển sang dùng vòng lặp để tô màu luôn ạ.

 

[nhnn1986]

Cảm ơn anh @snow25 code chạy đúng với nếu tới cột K
Số liệu của em có số cột không cố định ạ có tuần thì tới cột AA, có tuần chạy tới cột AQ luôn ạ.
Vậy em muốn có chỉnh sửa xíu ở cột sẽ là lastcolumn chứ không cố định ạ./.

 

[snow25]

Cảm ơn anh @snow25 code chạy đúng với nếu tới cột K
Số liệu của em có số cột không cố định ạ có tuần thì tới cột AA, có tuần chạy tới cột AQ luôn ạ.
Vậy em muốn có chỉnh sửa xíu ở cột sẽ là lastcolumn chứ không cố định ạ./.

Bạn thử sub này.

Sub linhtinh()
    Dim arr, dic As Object, i As Long, j As Long, lr As Long, dk As String, lc As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("Kiem_tra")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:A" & lr).Value
         For i = 1 To UBound(arr, 1)
             dk = Left(arr(i, 1), 6) & "#" & Mid(arr(i, 1), 17, 8)
             If Not dic.exists(dk) Then
                dic.Add dk, ""
             End If
         Next i
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         lc = .Cells(1, 1000).End(xlToLeft).Column
         If lr = 1 Then Exit Sub
         arr = .Range("B1").Resize(lr, lc - 1).Value
         For i = 2 To UBound(arr, 1)
             For j = 2 To UBound(arr, 2)
                  dk = arr(i, 1) & "#" & arr(1, j)
                  If dic.exists(dk) Then
                     arr(i, j) = "YES"
                      .Cells(i, j + 1).Font.ColorIndex = 5
                  Else
                     arr(i, j) = "NO"
                     .Cells(i, j + 1).Font.ColorIndex = 3
                  End If
             Next j
        Next i
        .Range("B1").Resize(lr, lc - 1) = arr
  End With
End Sub

 

[nhnn1986]

Tuyệt vời ạ Mr @snow25 code chạy đúng ý em và nhanh nữa rồi ạ hí hí.

Thanks again Ms Oanh Thơ, Mr Leo.
Have a nice day all./.