Giúp viết code VBA lọc mã duy nhất và lấy dữ liệu theo điều kiện

[hoalv1985]

Em nhờ Anh/Chị viết giúp em code để lấy dữ liệu, resize theo điều kiện. Em có mô tả trong file đính kèm ạ. Em cảm ơn Anh/ Chị nhiều ạ!

Bài đã được tự động gộp: 4/3/23

Bài đã được tự động gộp: 4/3/23

Em đính lại file ạ

 

[BuiQuangThuan]

Em nhờ Anh/Chị viết giúp em code để lấy dữ liệu, resize theo điều kiện. Em có mô tả trong file đính kèm ạ. Em cảm ơn Anh/ Chị nhiều ạ!

Bài đã được tự động gộp: 4/3/23

Bài đã được tự động gộp: 4/3/23

Em đính lại file ạ

Chép lại cho dẻo tay

 

[Hoàng Tuấn 868]

Chép lại cho dẻo tay
View attachment 287144

Bài này làm thủ công thì mất khoảng gần một phút, vba là hơi phí.

 

[hoalv1985]

Chép lại cho dẻo tay
View attachment 287144

Anh ơi, ký tự gạch thẳng đứng viết thế nào anh, em ko tìm được ký tự đó trên bàn phím anh ạ.

 

[BuiQuangThuan]

Anh ơi, ký tự gạch thẳng đứng viết thế nào anh, em ko tìm được ký tự đó trên bàn phím anh ạ.

Thay bằng kí tự khác cũng được hoặc "|"

 

[hoalv1985]

Bài này làm thủ công thì mất khoảng gần một phút, vba là hơi phí.

Dạ anh, vì dữ liệu sau nhiều í anh. mỗi lần lại lọc trùng rồi lại copy vào thì hơi mệt anh ạ.

 

[Hoàng Tuấn 868]

Dạ anh, vì dữ liệu sau nhiều í anh. mỗi lần lại lọc trùng rồi lại copy vào thì hơi mệt anh ạ.

Ghi lại các thao tác lượt đầu rồi khi nào dùng thì "bấm một phát thôi".

 

[BuiQuangThuan]

Ghi lại các thao tác lượt đầu rồi khi nào dùng thì "bấm một phát thôi".

Cái này nếu biết 1 xíu thì có thể record macro để đạt được mục đích mà. Nhưng có vẻ thớt cũng lười. Và tận dụng được những thành phần ngứa tay như em.

 

[SA_DQ]

Bài này làm thủ công thì mất khoảng gần một phút, vba là hơi phí.

Chủ bài đăng muốn chỉ mất ~1 gy thôi bạn à!

→ → → → → → → → → → → → → → → → → → → → → → → → → → →​

 

[Hoàng Tuấn 868]

Nhưng có vẻ thớt cũng lười.

Bạn này vào diễn đàn gần 10 năm rồi mà vẫn đi nhờ suốt thế nhỉ.

 

[hoalv1985]

Chép lại cho dẻo tay
View attachment 287144

Sub abc()
Dim dic As Object, sarr(), res(), i&, s, key, k&, m&
Dim rng As Range
Set rng = Sheets("Data pb").Range("A3:B46")
Set dic = CreateObject("scripting.dictionary")
With Sheets("NKC")
sarr = .Range("P4:T" & .Range("T" & Rows.Count).End(xlUp).Row).Value
ReDim res(1 To UBound(sarr), 1 To 3)
For i = 1 To UBound(sarr)
If InStr(1, dic(sarr(i, 5)), sarr(i, 1)) = 0 Then
dic(sarr(i, 5)) = dic(sarr(i, 5)) & "|" & sarr(i, 1)
End If
Next i
For Each key In dic.key
s = Split(dic(key), "|")
For i = 0 To UBound(s)
k = k + 1
If i = 0 Then
m = m + 1
res(k, 1) = WorksheetFunction.Roman(m)
res(k, 2) = key
res(k, 3) = WorksheetFunction.VLookup(kye, rng, 2, 0)
Else
res(k, 2) = s(i)
End If
Next i
Next
End With
Sheets("Bao cao").Range("D3").Resize(k, 3).Value = res
End Sub
Anh ơi, em viết lại code như anh mà sao ko chạy được anh nhỉ

 

[BuiQuangThuan]

Anh ơi, em viết lại code như anh mà sao ko chạy được anh nhỉ

Đơn giản là chép lại sai thôi

Option Explicit
Sub ABC()
    Dim dic As Object, sarr(), es(), i&, s, key, k&, m&
    Dim rng As Range
    Set rng = Sheets("Data pb").Range("A3:B46")
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("NKC")
        sarr = .Range("P4:T" & .Range("T" & Rows.Count).End(3).Row).Value
        ReDim res(1 To UBound(sarr), 1 To 3)
        For i = 1 To UBound(sarr)
            If InStr(1, dic(sarr(i, 5)), sarr(i, 1)) = 0 Then
                dic(sarr(i, 5)) = dic(sarr(i, 5)) & "|" & sarr(i, 1)
            End If
        Next
        For Each key In dic.keys
            s = Split(dic(key), "|")
            For i = 0 To UBound(s)
                k = k + 1
                If i = 0 Then
                    m = m + 1
                    res(k, 1) = WorksheetFunction.Roman(m)
                    res(k, 2) = key
                    res(k, 3) = WorksheetFunction.VLookup(key, rng, 2, 0)
                Else
                    res(k, 2) = s(i)
                End If
            Next
        Next
    End With
    Sheets("Bao cao").Range("D3").Resize(k, 3).Value = res
End Sub

 

[hoalv1985]

Đơn giản là chép lại sai thôi
View attachment 287147

Option Explicit
Sub ABC()
    Dim dic As Object, sarr(), es(), i&, s, key, k&, m&
    Dim rng As Range
    Set rng = Sheets("Data pb").Range("A3:B46")
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("NKC")
        sarr = .Range("P4:T" & .Range("T" & Rows.Count).End(3).Row).Value
        ReDim res(1 To UBound(sarr), 1 To 3)
        For i = 1 To UBound(sarr)
            If InStr(1, dic(sarr(i, 5)), sarr(i, 1)) = 0 Then
                dic(sarr(i, 5)) = dic(sarr(i, 5)) & "|" & sarr(i, 1)
            End If
        Next
        For Each key In dic.keys
            s = Split(dic(key), "|")
            For i = 0 To UBound(s)
                k = k + 1
                If i = 0 Then
                    m = m + 1
                    res(k, 1) = WorksheetFunction.Roman(m)
                    res(k, 2) = key
                    res(k, 3) = WorksheetFunction.VLookup(key, rng, 2, 0)
                Else
                    res(k, 2) = s(i)
                End If
            Next
        Next
    End With
    Sheets("Bao cao").Range("D3").Resize(k, 3).Value = res
End Sub

Dạ anh, nhưng vẫn báo lỗi anh à, em sửa lại thành key rồi mà vẫn báo lỗi ạ

Bài đã được tự động gộp: 4/3/23

Đơn giản là chép lại sai thôi
View attachment 287147

Option Explicit
Sub ABC()
    Dim dic As Object, sarr(), es(), i&, s, key, k&, m&
    Dim rng As Range
    Set rng = Sheets("Data pb").Range("A3:B46")
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("NKC")
        sarr = .Range("P4:T" & .Range("T" & Rows.Count).End(3).Row).Value
        ReDim res(1 To UBound(sarr), 1 To 3)
        For i = 1 To UBound(sarr)
            If InStr(1, dic(sarr(i, 5)), sarr(i, 1)) = 0 Then
                dic(sarr(i, 5)) = dic(sarr(i, 5)) & "|" & sarr(i, 1)
            End If
        Next
        For Each key In dic.keys
            s = Split(dic(key), "|")
            For i = 0 To UBound(s)
                k = k + 1
                If i = 0 Then
                    m = m + 1
                    res(k, 1) = WorksheetFunction.Roman(m)
                    res(k, 2) = key
                    res(k, 3) = WorksheetFunction.VLookup(key, rng, 2, 0)
                Else
                    res(k, 2) = s(i)
                End If
            Next
        Next
    End With
    Sheets("Bao cao").Range("D3").Resize(k, 3).Value = res
End Sub

Em cảm ơn anh ạ! Chúc anh cuối tuần vui vẻ ạ

Bài đã được tự động gộp: 4/3/23

Chủ bài đăng muốn chỉ mất ~1 gy thôi bạn à!

→ → → → → → → → → → → → → → → → → → → → → → → → → → →​

Em cảm ơn anh nhiều ạ. Chúc anh cuối tuần vui vẻ và hạnh phúc anh ạ

Bài đã được tự động gộp: 4/3/23

Cái này nếu biết 1 xíu thì có thể record macro để đạt được mục đích mà. Nhưng có vẻ thớt cũng lười. Và tận dụng được những thành phần ngứa tay như em.

ko phải em lười anh à, khi sheet NKC tháng sau phát sinh thêm mã phí mới thì ko recode được ạ

 

[Hoàng Tuấn 868]

Tiêu đề bài này nên đổi thành: "Giúp viết code VBA lọc mã duy nhất và lấy dữ liệu theo điều kiện" để ai muốn tìm theo chủ đề này sẽ dễ dàng tìm thấy.

 

[snow25]

Chép lại cho dẻo tay
View attachment 287144

Tại sao không chạy duyệt sheets Data pb trước rồi chạy sheets NKC sau có phải đơn giản hơn không mà không cần sử dụng hàm Vlookup nữa.

 

[BuiQuangThuan]

Tại sao không chạy duyệt sheets Data pb trước rồi chạy sheets NKC sau có phải đơn giản hơn không mà không cần sử dụng hàm Vlookup nữa.

Ừ nhỉ. Cách của anh cũng là 1 cách. Hihi. Lúc ấy nghĩ sao thì viết thế ấy mà anh

 

[hoalv1985]

Đơn giản là chép lại sai thôi
View attachment 287147

Option Explicit
Sub ABC()
    Dim dic As Object, sarr(), es(), i&, s, key, k&, m&
    Dim rng As Range
    Set rng = Sheets("Data pb").Range("A3:B46")
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("NKC")
        sarr = .Range("P4:T" & .Range("T" & Rows.Count).End(3).Row).Value
        ReDim res(1 To UBound(sarr), 1 To 3)
        For i = 1 To UBound(sarr)
            If InStr(1, dic(sarr(i, 5)), sarr(i, 1)) = 0 Then
                dic(sarr(i, 5)) = dic(sarr(i, 5)) & "|" & sarr(i, 1)
            End If
        Next
        For Each key In dic.keys
            s = Split(dic(key), "|")
            For i = 0 To UBound(s)
                k = k + 1
                If i = 0 Then
                    m = m + 1
                    res(k, 1) = WorksheetFunction.Roman(m)
                    res(k, 2) = key
                    res(k, 3) = WorksheetFunction.VLookup(key, rng, 2, 0)
                Else
                    res(k, 2) = s(i)
                End If
            Next
        Next
    End With
    Sheets("Bao cao").Range("D3").Resize(k, 3).Value = res
End Sub

Anh ơi, cột B khi lấy sang thì phần số bị sai anh à. Bên NKC đang để dạng Text, nhưng khi lấy sang thì lại trở về dạng số, nên sẽ bị mất số 0 ở đầu anh à.

 

[BuiQuangThuan]

Anh ơi, cột B khi lấy sang thì phần số bị sai anh à. Bên NKC đang để dạng Text, nhưng khi lấy sang thì lại trở về dạng số, nên sẽ bị mất số 0 ở đầu anh à.

Trước khi chạy đoạn code trên thì hãy định dạng cột B đấy thành dạng text là được chứ có gì đâu

 

[hoalv1985]

Anh ơi, cột B khi lấy sang thì phần số bị sai anh à. Bên NKC đang để dạng Text, nhưng khi lấy sang thì lại trở về dạng số, nên sẽ bị mất số 0 ở đầu anh à.

Anh ơi, cũng là cái bảng đó, nhưng em thêm 1 cột kết quả ở cột E. Như file đính kèm, anh giúp nốt em với anh ơi. Em cảm ơn anh ạ!

 

[bebo021999]

em thêm 1 cột kết quả ở cột E.

Có vẻ cột E cũng chỉ là cột trung gian, nối chuỗi 2 mã với nhau, mục đích để SUMIF hay VLOOKUP gì đó để ra báo cáo khác.
Bạn cho luôn kết quả muốn có đi nhé, biết đâu lại không cần cột E nữa thì sao.