So sánh 2 sheet và trả về kết quả sai lệch

Liên hệ QC
V

vuongphuc

Thành viên mới
Tham gia
3/11/21
Bài viết
4
Được thích
0
Mình có 2 sheet dữ liệu và một sheet so sánh sai lệch, mình thường làm làm bằng Pivot Table, nhưng thao tác phải lặp lại mỗi khi thay đổi dữ liệu. Mình nhờ các bạn viết giúp code VBA để mình so sánh được nhanh và hiệu quả hơn. Trân trọng cảm ơn.
Chi tiết mẫu theo file đính kèm
 

File đính kèm

vuongphuc đã viết:
Mình có 2 sheet dữ liệu và một sheet so sánh sai lệch, mình thường làm làm bằng Pivot Table, nhưng thao tác phải lặp lại mỗi khi thay đổi dữ liệu. Mình nhờ các bạn viết giúp code VBA để mình so sánh được nhanh và hiệu quả hơn. Trân trọng cảm ơn.
Chi tiết mẫu theo file đính kèm
Nhấp chuột vào đây để mở rộng...
1/ Nếu chứng từ nào bằng nhau giữa 2 sheet thì không kê ra ở sheet so sánh? Đúng lý ra phải kê lên hết dù hiệu số = 0
2/ Tại sao ở sheet2, chứng từ không có đuôi /GNT?
 
vuongphuc đã viết:
Mình có 2 sheet dữ liệu và một sheet so sánh sai lệch, mình thường làm làm bằng Pivot Table, nhưng thao tác phải lặp lại mỗi khi thay đổi dữ liệu. Mình nhờ các bạn viết giúp code VBA để mình so sánh được nhanh và hiệu quả hơn. Trân trọng cảm ơn.
Chi tiết mẫu theo file đính kèm
Nhấp chuột vào đây để mở rộng...
Góp vui, bạn dùng thử trong khi chờ các giải pháp khác.
Hãy nhấn nút SO SANH ở sh3 và xem kết quả
Mã: 
Sub SoSanh()
Dim i&, j&, k&, Lr1&, Lr2&, n&, m&
Dim Arr1(), Arr2(), KQ(), KETQUA()
Dim Dic As Object
With Sheet1
Lr1 = .Cells(Rows.Count, 1).End(xlUp).Row
Arr1 = .Range("A2:C" & Lr1).Value
R1 = UBound(Arr1)
End With
With Sheet2
Lr2 = .Cells(Rows.Count, 1).End(xlUp).Row
Arr2 = .Range("A2:C" & Lr2).Value
R2 = UBound(Arr2)
End With
ReDim KQ(1 To R1 + R2, 1 To 5)
Set Dic = CreateObject("scripting.dictionary")

For i = 1 To R1
    Keys = Application.Substitute(Trim(Arr1(i, 1)), "/GNT", "")
    If Not Dic.Exists(Keys) Then
        t = t + 1
        Dic.Add (Keys), t
        KQ(t, 1) = Format(Keys, "0000#")
        KQ(t, 2) = Arr1(i, 2)
        KQ(t, 3) = Arr1(i, 3)
    Else
        k = Dic.Item(Keys)
        KQ(k, 2) = Arr1(i, 2)
        KQ(k, 3) = KQ(k, 3) + Arr1(i, 3)
    End If
        KQ(t, 5) = KQ(t, 3) - KQ(t, 4)
Next i
For j = 1 To R2
    Temp = Trim(Arr2(j, 1))
    If Not Dic.Exists(Temp) Then
        t = t + 1
        KQ(t, 1) = Format(Temp, "0000#")
        KQ(t, 2) = Arr2(j, 2)
        KQ(t, 4) = Arr2(j, 3)
    Else
        k = Dic.Item(Temp)
        KQ(k, 2) = Arr2(j, 2)
        KQ(k, 4) = KQ(k, 4) + Arr2(j, 3)
        KQ(k, 5) = KQ(k, 3) - KQ(k, 4)
    End If
        KQ(t, 5) = KQ(t, 3) - KQ(t, 4)
Next j
ReDim KETQUA(1 To t, 1 To 5)
For n = 1 To t
    If KQ(n, 3) <> KQ(n, 4) Then
        Z = Z + 1
        For m = 1 To 5
            KETQUA(Z, m) = KQ(n, m)
        Next m
            KETQUA(Z, 1) = Format(KETQUA(Z, 1), "0000#")
    End If
Next n
If Z Then
Sheet3.Cells(2, 1).Resize(Z + 5, 5).ClearContents
Sheet3.Cells(2, 1).Resize(Z, 5) = KETQUA
End If
Set Dic = Nothing
MsgBox " Xong"
End Sub
anh chị em có ghé xem xin góp ý để code được ngắn gọn và xử lý được hết các trường hợp xảy ra. Trân trọng.
 

File đính kèm

Tôi đề nghị vẫn phải kê các chứng từ khớp số liệu vì có như thế dữ liệu của cột Tổng sheet1 và Tổng sheet2 mới toàn vẹn và ta cũng biết được chứng từ nào khớp.
Rich (BB code): 
Sub SS2Sheet()
Dim arrS1, arrS2, arrRsl, Dic As Object
Dim i&, k&, dKey$

    arrS1 = Sheet1.Range("A2:C" & Sheet1.Range("A" & Rows.Count).End(xlUp).Row)
    arrS2 = Sheet2.Range("A2:C" & Sheet2.Range("A" & Rows.Count).End(xlUp).Row)
    Set Dic = CreateObject("Scripting.Dictionary")
    ReDim arrRsl(1 To UBound(arrS1) + UBound(arrS2), 1 To 5)
    For i = 1 To UBound(arrS1)
        dKey = arrS1(i, 1)
        If Not Dic.Exists(dKey) Then
            k = k + 1
            Dic.Add dKey, k
            arrRsl(k, 1) = dKey
            arrRsl(k, 2) = arrS1(i, 2)
            arrRsl(k, 3) = arrS1(i, 3)
            arrRsl(k, 4) = 0
            arrRsl(k, 5) = arrS1(i, 3)
        Else
            arrRsl(Dic.Item(dKey), 3) = arrRsl(Dic.Item(dKey), 3) + arrS1(i, 3)
            arrRsl(Dic.Item(dKey), 5) = arrRsl(Dic.Item(dKey), 5) + arrS1(i, 3)
        End If
    Next
    For i = 1 To UBound(arrS2)
        dKey = arrS2(i, 1) & "/GNT"
        If Not Dic.Exists(dKey) Then
            k = k + 1
            Dic.Add dKey, k
            arrRsl(k, 1) = dKey
            arrRsl(k, 2) = arrS2(i, 2)
            arrRsl(k, 3) = 0
            arrRsl(k, 4) = arrS2(i, 3)
            arrRsl(k, 5) = -arrS2(i, 3)
        Else
            arrRsl(Dic.Item(dKey), 4) = arrRsl(Dic.Item(dKey), 4) + arrS2(i, 3)
            arrRsl(Dic.Item(dKey), 5) = arrRsl(Dic.Item(dKey), 5) - arrS2(i, 3)
        End If
    Next
    Sheet3.Range("A2").Resize(UBound(arrS1) + UBound(arrS2), 5).ClearContents
    Sheet3.Range("A2").Resize(k, 5) = arrRsl
    Set Dic = Nothing
End Sub

@HUONGHCKT: Ở cột 5 mảng kết quả, nếu là dữ liệu sheet1 thì cộng, sheet2 thì trừ là dễ hiểu nhất chứ làm như bạn rất khó bảo trì code.
 
Maika8008 đã viết:
1/ Nếu chứng từ nào bằng nhau giữa 2 sheet thì không kê ra ở sheet so sánh? Đúng lý ra phải kê lên hết dù hiệu số = 0
2/ Tại sao ở sheet2, chứng từ không có đuôi /GNT?
Nhấp chuột vào đây để mở rộng...
1. Vì để sheet3 giảm tải dung lượng và loại bỏ các chứng từ đã khớp nên sau khi lọc autofilter mình đã bỏ dòng khớp (chênh lệch bằng 0)
2. Sheet1 là bảng kê đã nhập nên phần mềm tự sinh ra đuôi để phân biệt nhập vào khu vực nào, còn sheet2 không có đuôi vì nó là chứng từ nhân về để cập nhật vào sheet1, sẽ có lúc điều chỉnh,... làm sai lệch 2 sheet
 
HUONGHCKT đã viết:
Góp vui, bạn dùng thử trong khi chờ các giải pháp khác.
Hãy nhấn nút SO SANH ở sh3 và xem kết quả
Mã: 
Sub SoSanh()
Dim i&, j&, k&, Lr1&, Lr2&, n&, m&
Dim Arr1(), Arr2(), KQ(), KETQUA()
Dim Dic As Object
With Sheet1
Lr1 = .Cells(Rows.Count, 1).End(xlUp).Row
Arr1 = .Range("A2:C" & Lr1).Value
R1 = UBound(Arr1)
End With
With Sheet2
Lr2 = .Cells(Rows.Count, 1).End(xlUp).Row
Arr2 = .Range("A2:C" & Lr2).Value
R2 = UBound(Arr2)
End With
ReDim KQ(1 To R1 + R2, 1 To 5)
Set Dic = CreateObject("scripting.dictionary")

For i = 1 To R1
    Keys = Application.Substitute(Trim(Arr1(i, 1)), "/GNT", "")
    If Not Dic.Exists(Keys) Then
        t = t + 1
        Dic.Add (Keys), t
        KQ(t, 1) = Format(Keys, "0000#")
        KQ(t, 2) = Arr1(i, 2)
        KQ(t, 3) = Arr1(i, 3)
    Else
        k = Dic.Item(Keys)
        KQ(k, 2) = Arr1(i, 2)
        KQ(k, 3) = KQ(k, 3) + Arr1(i, 3)
    End If
        KQ(t, 5) = KQ(t, 3) - KQ(t, 4)
Next i
For j = 1 To R2
    Temp = Trim(Arr2(j, 1))
    If Not Dic.Exists(Temp) Then
        t = t + 1
        KQ(t, 1) = Format(Temp, "0000#")
        KQ(t, 2) = Arr2(j, 2)
        KQ(t, 4) = Arr2(j, 3)
    Else
        k = Dic.Item(Temp)
        KQ(k, 2) = Arr2(j, 2)
        KQ(k, 4) = KQ(k, 4) + Arr2(j, 3)
        KQ(k, 5) = KQ(k, 3) - KQ(k, 4)
    End If
        KQ(t, 5) = KQ(t, 3) - KQ(t, 4)
Next j
ReDim KETQUA(1 To t, 1 To 5)
For n = 1 To t
    If KQ(n, 3) <> KQ(n, 4) Then
        Z = Z + 1
        For m = 1 To 5
            KETQUA(Z, m) = KQ(n, m)
        Next m
            KETQUA(Z, 1) = Format(KETQUA(Z, 1), "0000#")
    End If
Next n
If Z Then
Sheet3.Cells(2, 1).Resize(Z + 5, 5).ClearContents
Sheet3.Cells(2, 1).Resize(Z, 5) = KETQUA
End If
Set Dic = Nothing
MsgBox " Xong"
End Sub
anh chị em có ghé xem xin góp ý để code được ngắn gọn và xử lý được hết các trường hợp xảy ra. Trân trọng.
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn, để mình tải về chạy thử
Bài đã được tự động gộp:

Maika8008 đã viết:
Tôi đề nghị vẫn phải kê các chứng từ khớp số liệu vì có như thế dữ liệu của cột Tổng sheet1 và Tổng sheet2 mới toàn vẹn và ta cũng biết được chứng từ nào khớp.
Rich (BB code): 
Sub SS2Sheet()
Dim arrS1, arrS2, arrRsl, Dic As Object
Dim i&, k&, dKey$

    arrS1 = Sheet1.Range("A2:C" & Sheet1.Range("A" & Rows.Count).End(xlUp).Row)
    arrS2 = Sheet2.Range("A2:C" & Sheet2.Range("A" & Rows.Count).End(xlUp).Row)
    Set Dic = CreateObject("Scripting.Dictionary")
    ReDim arrRsl(1 To UBound(arrS1) + UBound(arrS2), 1 To 5)
    For i = 1 To UBound(arrS1)
        dKey = arrS1(i, 1)
        If Not Dic.Exists(dKey) Then
            k = k + 1
            Dic.Add dKey, k
            arrRsl(k, 1) = dKey
            arrRsl(k, 2) = arrS1(i, 2)
            arrRsl(k, 3) = arrS1(i, 3)
            arrRsl(k, 4) = 0
            arrRsl(k, 5) = arrS1(i, 3)
        Else
            arrRsl(Dic.Item(dKey), 3) = arrRsl(Dic.Item(dKey), 3) + arrS1(i, 3)
            arrRsl(Dic.Item(dKey), 5) = arrRsl(Dic.Item(dKey), 5) + arrS1(i, 3)
        End If
    Next
    For i = 1 To UBound(arrS2)
        dKey = arrS2(i, 1) & "/GNT"
        If Not Dic.Exists(dKey) Then
            k = k + 1
            Dic.Add dKey, k
            arrRsl(k, 1) = dKey
            arrRsl(k, 2) = arrS2(i, 2)
            arrRsl(k, 3) = 0
            arrRsl(k, 4) = arrS2(i, 3)
            arrRsl(k, 5) = -arrS2(i, 3)
        Else
            arrRsl(Dic.Item(dKey), 4) = arrRsl(Dic.Item(dKey), 4) + arrS2(i, 3)
            arrRsl(Dic.Item(dKey), 5) = arrRsl(Dic.Item(dKey), 5) - arrS2(i, 3)
        End If
    Next
    Sheet3.Range("A2").Resize(UBound(arrS1) + UBound(arrS2), 5).ClearContents
    Sheet3.Range("A2").Resize(k, 5) = arrRsl
    Set Dic = Nothing
End Sub

@HUONGHCKT: Ở cột 5 mảng kết quả, nếu là dữ liệu sheet1 thì cộng, sheet2 thì trừ là dễ hiểu nhất chứ làm như bạn rất khó bảo trì code.
Nhấp chuột vào đây để mở rộng...
Vì số liệu tháng lên nhiều dòng, khi chạy cả năm sẽ làm tăng dữ liệu rất nhiều, nên mình mong muốn giảm bớt các dòng đã khớp để giảm dung lượng và tăng hiệu quả xử lý dữ liệu. Thanks bạn nhiều
 
vuongphuc đã viết:
Cảm ơn bạn, để mình tải về chạy thử
Bài đã được tự động gộp:


Vì số liệu tháng lên nhiều dòng, khi chạy cả năm sẽ làm tăng dữ liệu rất nhiều, nên mình mong muốn giảm bớt các dòng đã khớp để giảm dung lượng và tăng hiệu quả xử lý dữ liệu. Thanks bạn nhiều
Nhấp chuột vào đây để mở rộng...
Vậy thì thêm vài dòng lệnh và sửa chút:
Rich (BB code): 
Sub SS2Sheet()
Dim arrS1, arrS2, arrRsl, Dic As Object
Dim i&, k&, j&, d&, dKey$

    arrS1 = Sheet1.Range("A2:C" & Sheet1.Range("A" & Rows.Count).End(xlUp).Row)
    arrS2 = Sheet2.Range("A2:C" & Sheet2.Range("A" & Rows.Count).End(xlUp).Row)
    Set Dic = CreateObject("Scripting.Dictionary")
    ReDim arrRsl(1 To UBound(arrS1) + UBound(arrS2), 1 To 5)
    For i = 1 To UBound(arrS1)
        dKey = arrS1(i, 1)
        If Not Dic.Exists(dKey) Then
            k = k + 1
            Dic.Add dKey, k
            arrRsl(k, 1) = dKey
            arrRsl(k, 2) = arrS1(i, 2)
            arrRsl(k, 3) = arrS1(i, 3)
            arrRsl(k, 4) = 0
            arrRsl(k, 5) = arrS1(i, 3)
        Else
            arrRsl(Dic.Item(dKey), 3) = arrRsl(Dic.Item(dKey), 3) + arrS1(i, 3)
            arrRsl(Dic.Item(dKey), 5) = arrRsl(Dic.Item(dKey), 5) + arrS1(i, 3)
        End If
    Next
    For i = 1 To UBound(arrS2)
        dKey = arrS2(i, 1) & "/GNT"
        If Not Dic.Exists(dKey) Then
            k = k + 1
            Dic.Add dKey, k
            arrRsl(k, 1) = dKey
            arrRsl(k, 2) = arrS2(i, 2)
            arrRsl(k, 3) = 0
            arrRsl(k, 4) = arrS2(i, 3)
            arrRsl(k, 5) = -arrS2(i, 3)
        Else
            arrRsl(Dic.Item(dKey), 4) = arrRsl(Dic.Item(dKey), 4) + arrS2(i, 3)
            arrRsl(Dic.Item(dKey), 5) = arrRsl(Dic.Item(dKey), 5) - arrS2(i, 3)
        End If
    Next
'Xóa dòng khớp sheet1 và sheet2
    For i = 1 To k
        If arrRsl(i, 5) <> 0 Then
            d = d + 1
            For j = 1 To UBound(arrRsl, 2)
                arrRsl(d, j) = arrRsl(i, j)
            Next
        End If
    Next
    Sheet3.Range("A2").Resize(UBound(arrS1) + UBound(arrS2), 5).ClearContents
    Sheet3.Range("A2").Resize(d, 5) = arrRsl
    Set Dic = Nothing
End Sub
 
Maika8008 đã viết:
Vậy thì thêm vài dòng lệnh và sửa chút:
Rich (BB code): 
Sub SS2Sheet()
Dim arrS1, arrS2, arrRsl, Dic As Object
Dim i&, k&, j&, d&, dKey$

    arrS1 = Sheet1.Range("A2:C" & Sheet1.Range("A" & Rows.Count).End(xlUp).Row)
    arrS2 = Sheet2.Range("A2:C" & Sheet2.Range("A" & Rows.Count).End(xlUp).Row)
    Set Dic = CreateObject("Scripting.Dictionary")
    ReDim arrRsl(1 To UBound(arrS1) + UBound(arrS2), 1 To 5)
    For i = 1 To UBound(arrS1)
        dKey = arrS1(i, 1)
        If Not Dic.Exists(dKey) Then
            k = k + 1
            Dic.Add dKey, k
            arrRsl(k, 1) = dKey
            arrRsl(k, 2) = arrS1(i, 2)
            arrRsl(k, 3) = arrS1(i, 3)
            arrRsl(k, 4) = 0
            arrRsl(k, 5) = arrS1(i, 3)
        Else
            arrRsl(Dic.Item(dKey), 3) = arrRsl(Dic.Item(dKey), 3) + arrS1(i, 3)
            arrRsl(Dic.Item(dKey), 5) = arrRsl(Dic.Item(dKey), 5) + arrS1(i, 3)
        End If
    Next
    For i = 1 To UBound(arrS2)
        dKey = arrS2(i, 1) & "/GNT"
        If Not Dic.Exists(dKey) Then
            k = k + 1
            Dic.Add dKey, k
            arrRsl(k, 1) = dKey
            arrRsl(k, 2) = arrS2(i, 2)
            arrRsl(k, 3) = 0
            arrRsl(k, 4) = arrS2(i, 3)
            arrRsl(k, 5) = -arrS2(i, 3)
        Else
            arrRsl(Dic.Item(dKey), 4) = arrRsl(Dic.Item(dKey), 4) + arrS2(i, 3)
            arrRsl(Dic.Item(dKey), 5) = arrRsl(Dic.Item(dKey), 5) - arrS2(i, 3)
        End If
    Next
'Xóa dòng khớp sheet1 và sheet2
    For i = 1 To k
        If arrRsl(i, 5) <> 0 Then
            d = d + 1
            For j = 1 To UBound(arrRsl, 2)
                arrRsl(d, j) = arrRsl(i, j)
            Next
        End If
    Next
    Sheet3.Range("A2").Resize(UBound(arrS1) + UBound(arrS2), 5).ClearContents
    Sheet3.Range("A2").Resize(d, 5) = arrRsl
    Set Dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn nhiều, code chạy rất ổn
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

V
  • Question Question
Tách số liệu từ bảng tính ngang theo điều kiện
Trả lời
10
Đọc
213
vanlinh_2904
V
P
Xin trợ giúp cách lập lịch trực tịnh tiến dần cho 1 nhóm người.
Trả lời
2
Đọc
50
Phuocam
Phuocam
minhquipk
  • Question Question
Cách nhận biết những ô đã bị thay đổi giá trị khi thay đổi giá trị dữ liệu ở những ô khác
Trả lời
3
Đọc
69
le_vis
L
HeSanbi
  • Đã giải quyết
LocalizeXL v1.72 - Làm nổi bật ô đang chọn và cuộn trang tự động
    • Thích
    • Yêu thích
2 3 4
Trả lời
63
Đọc
10K
125479980
125479980
H
Tìm kết quả trả về theo loại
Trả lời
9
Đọc
76
VetMini
V
LongHoang123
  • Question Question
Xin hướng dẫn: Cách tạo vùng in dựa trên dữ liệu của listbox bằng VBA!!!
Trả lời
4
Đọc
79
LongHoang123
LongHoang123
M
  • Question Question
"thủ tục để xóa dòng trống " trong Lập trình VBA trong Excel
2 3 4
Trả lời
63
Đọc
15K
SonBDND
S
Q
Hỏi về công thức dò giá
Trả lời
6
Đọc
182
thanthanhan0801
T
N
  • Question Question
VBA - copy các sheets unhide và dạng giá trị theo vùng xác định
Trả lời
6
Đọc
326
nguyenhuong34
nguyenhuong34
ThanhPhongDN
hỏi về cách thay đổi giá trị một ô sau khi nhập một giá trị vào đó
Trả lời
7
Đọc
138
vietduc147258
V
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Chấp nhận
2
Trả lời
34
Đọc
13K
hungbon7890
hungbon7890
A
  • Question Question
code vba chuyển chuỗi thành text
Trả lời
11
Đọc
2K
SonBDND
S
V
Xin giúp em file theo dõi thanh toán có bị quá hạn không, quá bao nhiêu ngày và bao nhiêu tiền ạ
Trả lời
11
Đọc
309
HUONGHCKT
H
Tandattb
Xin cách Khắc phục lỗi "Path/File access error"
Trả lời
8
Đọc
288
Tandattb
Tandattb
ThanhPhongDN
Nhờ giúp đỡ về công thức trong google sheet
    • Cười
Trả lời
4
Đọc
85
thuytrangbp28
T
saobekhonglac
Tạo form vòng quay may mắn
    • Thích
2
Trả lời
35
Đọc
15K
VetMini
V
D
Thống kê dữ liệu theo điều kiện
Trả lời
5
Đọc
138
VetMini
V
noisy
Xin file tính chế độ chuyên cần
    • Cười
Trả lời
0
Đọc
46
noisy
noisy
PhanTuHuong
CHỌN VÀ SỬ DỤNG MÁY LỌC KHÔNG KHÍ
    • Cảm ơn
Trả lời
3
Đọc
716
hvnhpro
H
hanhlx88
Nhờ giúp file Excel báo lỗi: Excel cannot complete this task with available resources
Trả lời
2
Đọc
122
leonguyenz
leonguyenz
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
Chúc mừng năm mới.
Back
Top Bottom