Hỏi! cách kết nối dữ liệu giữa 2 bảng dùng Scripting.Dictionary (1 người xem)

[phucbugis]

Xin chào các anh chị trong GPE,

Em muốn hỏi đoạn code bên dưới phải sửa lại như thế nào, để khi update số liệu từ bảng 2 vào bảng 1 thì các dòng được bôi màu vàng vẫn được giữ nguyên ko bị xoá.

Sub UpdateNcong()
Dim ArrMax, ArrDulieu, ArrKetQua, Dic, Dong As Long, i As Long, K As Long
Set Dic = CreateObject("Scripting.Dictionary")


    ArrMax = Range([B65500].End(xlUp), [B5]).Value
    For i = 1 To UBound(ArrMax, 1)
        If Not IsEmpty(ArrMax(i, 1)) And Not Dic.Exists(ArrMax(i, 1)) Then
            Dic.Add ArrMax(i, 1), i
        End If
    Next
    
    ReDim ArrKetQua(1 To UBound(ArrMax, 1), 1 To 5)
    ArrDulieu = Range([I65500].End(xlUp), [N5]).Value
    For K = 1 To UBound(ArrDulieu, 1)
        If Dic.Exists(ArrDulieu(K, 1)) Then
            Dong = Dic.Item(ArrDulieu(K, 1))
                
            ArrKetQua(Dong, 1) = ArrDulieu(K, 2)
            ArrKetQua(Dong, 2) = ArrDulieu(K, 3)
            ArrKetQua(Dong, 3) = ArrDulieu(K, 4)
            ArrKetQua(Dong, 4) = ArrDulieu(K, 5)
            ArrKetQua(Dong, 5) = ArrDulieu(K, 6)
        End If
    Next
    
    [C5:C245].Resize(, 5).Value = ArrKetQua
    
    Set Dic = Nothing
    MsgBox ("xong"), , "Thong bao'"
End Sub

Link: https://www.mediafire.com/?9d38babs76to14d

xin cảm ơn mọi người !

 

[Hoàng Trọng Nghĩa]

Thử thủ tục này đi, chả có "Dit to, Dit thon" gì ở đây cả!

Sub CapNhatNgayCong()
    
    Dim updt As Single
    Dim ubd1 As Long, ubd2 As Long
    Dim r1 As Long, r2 As Long, c As Long
    Dim RowCount As Long, LastRow1 As Long, LastRow2 As Long
    
    RowCount = Range("A:A").Rows.Count
    
    LastRow1 = Sheet1.Range("B" & RowCount).End(xlUp).Row
    LastRow2 = Sheet1.Range("I" & RowCount).End(xlUp).Row
    
    Dim ArrTable1(), ArrTable2()
    ArrTable1 = Sheet1.Range("B5:G" & LastRow1).Value2
    ArrTable2 = Sheet1.Range("I5:N" & LastRow2).Value2
    
    ubd1 = UBound(ArrTable1)
    ubd2 = UBound(ArrTable2)
    
    For r2 = 1 To ubd2
        For r1 = 1 To ubd1
            If ArrTable1(r1, 1) = ArrTable2(r2, 1) Then
                [COLOR=#ff0000][B]For c = 2 To 6[/B][/COLOR]
                    updt = ArrTable1(r1, c) + ArrTable2(r2, c)
                    If updt > 0 Then
                        ArrTable1(r1, c) = updt
                    End If
                Next
                Exit For
            End If
        Next
    Next
    
    Sheet1.Range("B5:G" & LastRow1) = ArrTable1
    
End Sub

 

[Hoàng Trọng Nghĩa]

Nếu 2 bảng đều được SORT ở cột MÃ CNV thì thủ tục sau còn nhanh hơn nữa:

Sub CapNhatNgayCong2()
    
    Dim updt As Single
    Dim ubd1 As Long, ubd2 As Long
    Dim r1 As Long, r2 As Long, c As Long
    Dim RowCount As Long, LastRow1 As Long, LastRow2 As Long
    
    RowCount = Columns(1).Rows.Count
    
    LastRow1 = Sheet1.Range("B" & RowCount).End(xlUp).Row
    LastRow2 = Sheet1.Range("I" & RowCount).End(xlUp).Row
    
    Dim ArrTable1(), ArrTable2()
    ArrTable1 = Sheet1.Range("B5:G" & LastRow1).Value2
    ArrTable2 = Sheet1.Range("I5:N" & LastRow2).Value2
    
    ubd1 = UBound(ArrTable1)
    ubd2 = UBound(ArrTable2)
    
[COLOR=#ff0000][B]    r1 = 1[/B][/COLOR]
    For r2 = 1 To ubd2
[COLOR=#ff0000][B]        For r1 = r1 To ubd1[/B][/COLOR]
            If ArrTable1(r1, 1) = ArrTable2(r2, 1) Then
                For c = 2 To 6
                    updt = ArrTable1(r1, c) + ArrTable2(r2, c)
                    If updt > 0 Then
                        ArrTable1(r1, c) = updt
                    End If
                Next
[COLOR=#ff0000][B]                r1 = r1 + 1[/B][/COLOR]
                Exit For
            End If
        Next
    Next
    
    Sheet1.Range("B5:G" & LastRow1) = ArrTable1
    
End Sub

 

[Ba Tê]

Khoái Dic thì chạy thử Dic này:

Sub UpdateNcong()
Dim ArrDulieu(), ArrKQ(), Dic, I As Long, J As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
ArrKQ = Range([B5], [B65500].End(xlUp)).Resize(, 6).Value
ArrDulieu = Range([I5], [I65500].End(xlUp)).Resize(, 6).Value
For I = 1 To UBound(ArrDulieu, 1)
    Tem = ArrDulieu(I, 1)
    If Not IsEmpty(Tem) And Not Dic.Exists(Tem) Then
        Dic.Add Tem, I
    End If
Next I
For I = 1 To UBound(ArrKQ, 1)
    Tem = ArrKQ(I, 1)
    If Dic.Exists(Tem) Then
        For J = 2 To 6
            ArrKQ(I, J) = ArrDulieu(Dic.Item(Tem), J)
        Next J
    End If
Next I
[B5].Resize(UBound(ArrKQ, 1), 6) = ArrKQ
Set Dic = Nothing
End Sub

 

[Hoàng Trọng Nghĩa]

Khoái Dic thì chạy thử Dic này:

Sub UpdateNcong()
Dim ArrDulieu(), ArrKQ(), Dic, I As Long, J As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
ArrKQ = Range([B5], [B65500].End(xlUp)).Resize(, 6).Value
ArrDulieu = Range([I5], [I65500].End(xlUp)).Resize(, 6).Value
For I = 1 To UBound(ArrDulieu, 1)
    Tem = ArrDulieu(I, 1)
    If Not IsEmpty(Tem) And Not Dic.Exists(Tem) Then
        Dic.Add Tem, I
    End If
Next I
For I = 1 To UBound(ArrKQ, 1)
    Tem = ArrKQ(I, 1)
    If Dic.Exists(Tem) Then
        For J = 2 To 6
            ArrKQ(I, J) = ArrDulieu(Dic.Item(Tem), J)
        Next J
    End If
Next I
[B5].Resize(UBound(ArrKQ, 1), 6) = ArrKQ
Set Dic = Nothing
End Sub

Đã gọi là UPDATE thì lấy cũ cộng với mới thì cái này hình như chưa đầy đủ phải không bác Ba Tê nhỉ?

ArrKQ(I, J) = ArrDulieu(Dic.Item(Tem), J)

 

[Ba Tê]

Đã gọi là UPDATE thì lấy cũ cộng với mới thì cái này hình như chưa đầy đủ phải không bác Ba Tê nhỉ?

ArrKQ(I, J) = ArrDulieu(Dic.Item(Tem), J)

Uả????
Có biết là đem qua hay Cộng thêm đâu "Chời".
Đọc code của tác giả chỉ thấy "đem qua" thôi mà.
Mắc cộng thì thêm một cái cộng thôi mà.

ArrKQ(I, J) = ArrKQ(I, J) + ArrDulieu(Dic.Item(Tem), J)

 

[phucbugis]

Do mình mới tập làm quen với Scripting.Dictionary nên mò hoài ko ra nổi , + vừa biết thêm 1 cách làm mới của HTN nữa.

Ngày công của bảng 2 là số liệu mình lấy từ máy chấm công rồi update vào file lương (thông thường thì nhập lại ngày công từng mã ---> rất lâu + dễ sai sót)

Vấn đề đã được giải quyết,
cảm ơn 2 bác Hoàng Trọng Nghĩa và Batê nhiều nhé.