Lọc số liệu chênh lệch ở 2 danh sách theo điều kiện

Liên hệ QC
Tôi tuân thủ nội quy khi đăng bài
Có
V

vanlinh_2904

Thành viên hoạt động
Tham gia
20/10/12
Bài viết
105
Được thích
3
Chào các anh/ chị diễn đàn.
Em nhờ anh/chị viết giúp em VBA để lọc ra theo từng mã hàng và loại hàng có số lượng chênh lệch hoặc thành tiền chênh lệch ở 2 sheet DS1,DS2 (số lượng và thành tiền được tính tổng theo điều kiện từng mã hàng và loại hàng ở sheet DS1, DS2). Em cảm ơn các anh/chị.
 

File đính kèm

  • lockhacnhau_2.xlsm
    12.8 KB · Đọc: 13
Sắp xếp theo thời gian sắp xếp theo bầu chọn
vanlinh_2904 đã viết:
Em nhờ anh/chị viết giúp em VBA để lọc ra theo từng mã hàng và loại hàng có số lượng chênh lệch hoặc thành tiền chênh lệch ở 2 sheet DS1,DS2 (số lượng và thành tiền được tính tổng theo điều kiện từng mã hàng và loại hàng ở sheet DS1, DS2). Em cảm ơn các anh/chị.
Nhấp chuột vào đây để mở rộng...
Thử tham khảo code trong file.
Nhấn nút "chạy code" trong sheet Lech để được kết quả ở A12.
 

File đính kèm

  • lockhacnhau_2.xlsm
    24 KB · Đọc: 14
Upvote 0
HUONGHCKT đã viết:
Thử tham khảo code trong file.
Nhấn nút "chạy code" trong sheet Lech để được kết quả ở A12.
Nhấp chuột vào đây để mở rộng...
Mình chạy thấy nó lấy cả những mã không chênh lệch. mình muốn lọc ra những mã và loại có số lượng hoặc thành tiền chênh lệch, còn cái nào có cả số lượng và thành tiền không chênh lệch thì không lấy. cảm ơn bạn nhiều.
 
Upvote 0
vanlinh_2904 đã viết:
Mình chạy thấy nó lấy cả những mã không chênh lệch. mình muốn lọc ra những mã và loại có số lượng hoặc thành tiền chênh lệch, còn cái nào có cả số lượng và thành tiền không chênh lệch thì không lấy. cảm ơn bạn nhiều.
Nhấp chuột vào đây để mở rộng...
Trong khi chờ các giải pháp tốt hơn hãy thử Thay code cũ bằng code này xem sao:
Mã: 
Option Explicit

Sub LocLech()
Dim i&, j&, Lr&, t&, k&, R&, z&
Dim Arr(), KQ(), Res()
Dim Dic As Object
Dim Key, Tmp
Dim Ws As Worksheet, Sh1 As Worksheet, Sh2 As Worksheet
Set Sh1 = Sheets("DS1")
Lr = Sh1.Cells(1000000, 3).End(3).Row
Arr = Sh1.Range("C4:F" & Lr).Value
R = UBound(Arr)
ReDim KQ(1 To R, 1 To 9)
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To R
    If Arr(i, 1) <> Empty Then
        Key = Arr(i, 1) & "|" & Arr(i, 2)
    If Not Dic.Exists(Key) Then
        t = t + 1: Dic.Add (Key), t
        KQ(t, 1) = t
        KQ(t, 2) = Arr(i, 1)
        KQ(t, 3) = Arr(i, 2)
        KQ(t, 4) = Arr(i, 3)
        KQ(t, 7) = Arr(i, 4)
    Else
        k = Dic.Item(Key)
        KQ(k, 4) = KQ(k, 4) + Arr(i, 3)
        KQ(k, 7) = KQ(k, 7) + Arr(i, 4)
    End If
    End If
Next i
Set Sh1 = Sheets("DS2")
Lr = Sh1.Cells(1000000, 3).End(3).Row
Arr = Sh1.Range("B5:F" & Lr).Value
R = UBound(Arr)
For i = 1 To R
    If Arr(i, 1) <> Empty Then
        Key = Arr(i, 1) & "|" & Arr(i, 2)
    If Not Dic.Exists(Key) Then
        t = t + 1: Dic.Add (Key), t
        KQ(t, 2) = Arr(i, 1)
        KQ(t, 3) = Arr(i, 2)
        KQ(t, 5) = Arr(i, 3)
        KQ(t, 8) = Arr(i, 5)
    Else
         k = Dic.Item(Key)
        KQ(k, 5) = KQ(k, 5) + Arr(i, 3)
        KQ(k, 8) = KQ(k, 8) + Arr(i, 5)
    End If
    End If
Next i
ReDim Res(1 To t, 1 To 9)
For i = 1 To UBound(KQ)
    KQ(i, 6) = KQ(i, 4) - KQ(i, 5)
    KQ(i, 9) = KQ(i, 7) - KQ(i, 8)
If KQ(i, 4) - KQ(i, 5) <> KQ(i, 7) - KQ(i, 8) Then
    z = z + 1
    Res(z, 1) = z
    For j = 2 To 9
        Res(z, j) = KQ(i, j)
    Next j
End If
Next i
Set Ws = Sheets("Lech")
    Ws.Range("A12").Resize(t, 9) = Res
Set Dic = Nothing
MsgBox " Done"
End Sub
 
Upvote 0
Bạn tạo một bảng thông tin gồm 3 cột: Cột mã hàng, cột loại hàng, cột thứ 3 ghép 2 cột lại(làm Key liên kết), các cột này thì các dòng phải duy nhất không trùng nhé!
Hai cái bảng DS1, DS2 cũng tạo thêm cột Key bằng cách ghép mã hàng&loại hàng
Sau đó liên kết bảng thông tin với bảng Ds1, Ds2 thông qua trường Key
rồi dùng pivottable sẽ được kết quả. Quản lý hàng hóa và đơn hàng thì nên dùng như vậy để còn tùy biến, có hàng trăm hàng ngàn câu hỏi cho khách hàng, mã hàng, loại hàng. Chẳng lẽ mỗi câu hỏi lại lại viết một đoạn code VBA mới à, làm sao thấy được sự liên kết giữa chúng
 
Upvote 0
HUONGHCKT đã viết:
Trong khi chờ các giải pháp tốt hơn hãy thử Thay code cũ bằng code này xem sao:
Mã: 
Option Explicit

Sub LocLech()
Dim i&, j&, Lr&, t&, k&, R&, z&
Dim Arr(), KQ(), Res()
Dim Dic As Object
Dim Key, Tmp
Dim Ws As Worksheet, Sh1 As Worksheet, Sh2 As Worksheet
Set Sh1 = Sheets("DS1")
Lr = Sh1.Cells(1000000, 3).End(3).Row
Arr = Sh1.Range("C4:F" & Lr).Value
R = UBound(Arr)
ReDim KQ(1 To R, 1 To 9)
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To R
    If Arr(i, 1) <> Empty Then
        Key = Arr(i, 1) & "|" & Arr(i, 2)
    If Not Dic.Exists(Key) Then
        t = t + 1: Dic.Add (Key), t
        KQ(t, 1) = t
        KQ(t, 2) = Arr(i, 1)
        KQ(t, 3) = Arr(i, 2)
        KQ(t, 4) = Arr(i, 3)
        KQ(t, 7) = Arr(i, 4)
    Else
        k = Dic.Item(Key)
        KQ(k, 4) = KQ(k, 4) + Arr(i, 3)
        KQ(k, 7) = KQ(k, 7) + Arr(i, 4)
    End If
    End If
Next i
Set Sh1 = Sheets("DS2")
Lr = Sh1.Cells(1000000, 3).End(3).Row
Arr = Sh1.Range("B5:F" & Lr).Value
R = UBound(Arr)
For i = 1 To R
    If Arr(i, 1) <> Empty Then
        Key = Arr(i, 1) & "|" & Arr(i, 2)
    If Not Dic.Exists(Key) Then
        t = t + 1: Dic.Add (Key), t
        KQ(t, 2) = Arr(i, 1)
        KQ(t, 3) = Arr(i, 2)
        KQ(t, 5) = Arr(i, 3)
        KQ(t, 8) = Arr(i, 5)
    Else
         k = Dic.Item(Key)
        KQ(k, 5) = KQ(k, 5) + Arr(i, 3)
        KQ(k, 8) = KQ(k, 8) + Arr(i, 5)
    End If
    End If
Next i
ReDim Res(1 To t, 1 To 9)
For i = 1 To UBound(KQ)
    KQ(i, 6) = KQ(i, 4) - KQ(i, 5)
    KQ(i, 9) = KQ(i, 7) - KQ(i, 8)
If KQ(i, 4) - KQ(i, 5) <> KQ(i, 7) - KQ(i, 8) Then
    z = z + 1
    Res(z, 1) = z
    For j = 2 To 9
        Res(z, j) = KQ(i, j)
    Next j
End If
Next i
Set Ws = Sheets("Lech")
    Ws.Range("A12").Resize(t, 9) = Res
Set Dic = Nothing
MsgBox " Done"
End Sub
Nhấp chuột vào đây để mở rộng...
Bạn xem lại giúp mình khi số dòng ở sheet DS1 ít hơn sheet DS2 thì bị báo lỗi chỗ này ạ.
 

File đính kèm

  • loi.PNG
    loi.PNG
    14.9 KB · Đọc: 5
Upvote 0
vanlinh_2904 đã viết:
Nó vẫn bị bạn nhé, nếu số dòng ở sheet DS2 lớn hơn gấp 10 lần sheet DS1
Nhấp chuột vào đây để mở rộng...
Nếu đã vậy Bạn xác định ngay từ đầu luôn Arr1() là mảng của sh DS1, Arr2() là mảng của DS2 và tương ứng R1=Ubound(arr1), R2=Ubound(arr2).
Sau đó Redim KQ(1 to R1+R2, 1 to 9) và chạy thử
 
Upvote 0
Mặc dù bài đã được giải quyết tuy nhiên tôi vẫn cứ đăng lên đây 2 code đều giải quyết được yêu cầu của chủ thớt, với hy vọng có ai đó cần có tài liệu tham khảo.
1/Code do tôi viết:
Mã: 
Option Explicit

Sub LocLech()
Dim i&, j&, Lr1&, Lr2&, t&, k&, R2&, R1&, z&
Dim Arr1(), Arr2(), KQ(), Res()
Dim Dic As Object
Dim Key, Tmp
Dim Ws As Worksheet, Sh1 As Worksheet, Sh2 As Worksheet
Set Sh1 = Sheets("DS1")
Lr1 = Sh1.Cells(1000000, 3).End(3).Row
Arr1 = Sh1.Range("C4:F" & Lr1).Value
R1 = UBound(Arr1)
Set Sh1 = Sheets("DS2")
Lr2 = Sh1.Cells(1000000, 3).End(3).Row
Arr2 = Sh1.Range("B5:F" & Lr2).Value
R2 = UBound(Arr2)

ReDim KQ(1 To R1 + R2, 1 To 9)
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To R1
    If Arr1(i, 1) <> Empty Then
        Key = Arr1(i, 1) & "|" & Arr1(i, 2)
    If Not Dic.Exists(Key) Then
        t = t + 1: Dic.Add (Key), t
        KQ(t, 2) = Arr1(i, 1)
        KQ(t, 3) = Arr1(i, 2)
        KQ(t, 4) = Arr1(i, 3)
        KQ(t, 7) = Arr1(i, 4)
    Else
        k = Dic.Item(Key)
        KQ(k, 4) = KQ(k, 4) + Arr1(i, 3)
        KQ(k, 7) = KQ(k, 7) + Arr1(i, 4)
    End If
    End If
Next i

For i = 1 To R2
    If Arr2(i, 1) <> Empty Then
        Key = Arr2(i, 1) & "|" & Arr2(i, 2)
    If Not Dic.Exists(Key) Then
        t = t + 1: Dic.Add (Key), t
        KQ(t, 2) = Arr2(i, 1)
        KQ(t, 3) = Arr2(i, 2)
        KQ(t, 5) = Arr2(i, 3)
        KQ(t, 8) = Arr2(i, 5)
    Else
         k = Dic.Item(Key)
        KQ(k, 5) = KQ(k, 5) + Arr2(i, 3)
        KQ(k, 8) = KQ(k, 8) + Arr2(i, 5)
    End If
    End If
Next i
ReDim Res(1 To t, 1 To 9)
For i = 1 To UBound(KQ)
    KQ(i, 6) = KQ(i, 4) - KQ(i, 5)
    KQ(i, 9) = KQ(i, 7) - KQ(i, 8)
If KQ(i, 4) - KQ(i, 5) <> KQ(i, 7) - KQ(i, 8) Then
    z = z + 1
    Res(z, 1) = z
    For j = 2 To 9
        Res(z, j) = KQ(i, j)
    Next j
End If
Next i
Set Ws = Sheets("Lech")
    Ws.Range("A12").Resize(t, 9) = Res
Set Dic = Nothing
MsgBox " Done"
End Sub
2/ Và 1 code khác (theo kiểu dùng dict kiểu khác) do 1 người bạn rất có uy tín trên diễn đàn này viết. Xin phép tác giả code nhé.(bạn đó đã nhất trí công bố)
Code này là code xịn, nó có thể đúng cho mọi trường hợp như chủ thót đã đăng.
Mã: 
Option Explicit

Sub ABC()
    Dim Dic As Object, Arr(0 To 1), i&, Key, sArr(), n&, S, R&, Res()
    Dim SL1 As Double, SL2 As Double, TT1 As Double, TT2 As Double
    Set Dic = CreateObject("scripting.dictionary")
    Arr(0) = Sheets("DS1").Range("C4:F12").Value
    Arr(1) = Sheets("DS2").Range("B5:F13").Value
    For i = 0 To 1
        sArr = Arr(i)
        For n = 1 To UBound(sArr)
            Key = sArr(n, 1) & "|" & sArr(n, 2)
            Dic(Key) = Dic(Key) & "#" & n & "-DS" & i + 1
        Next
    Next
    ReDim Res(1 To UBound(Arr(0)) + UBound(Arr(1)), 1 To 8)
    n = 0
    For Each Key In Dic.keys
        SL1 = 0: SL2 = 0: TT1 = 0: TT2 = 0
        S = Split(Dic.Item(Key), "#")
        For i = 1 To UBound(S)
            R = --Split(S(i), "-")(0)
            If InStr(1, S(i), "-DS1") > 0 Then
                SL1 = SL1 + Arr(0)(R, 3): TT1 = TT1 + Arr(0)(R, 4)
            ElseIf InStr(1, S(i), "-DS2") > 0 Then
                SL2 = SL2 + Arr(1)(R, 3): TT2 = TT2 + Arr(1)(R, 5)
            End If
        Next
        If SL1 - SL2 <> 0 Or TT1 - TT2 <> 0 Then
            n = n + 1
            Res(n, 1) = Split(Key, "|")(0)
            Res(n, 2) = Split(Key, "|")(1)
            Res(n, 3) = SL1: Res(n, 4) = SL2
            Res(n, 5) = SL1 - SL2: Res(n, 6) = TT1
            Res(n, 7) = TT2: Res(n, 8) = TT1 - TT2
        End If
    Next
    With Sheets("Lech")
        If n > 0 Then
            .Range("K12").Resize(n, 8).Value = Res
        End If
    End With
End Sub
Rất cảm khích mọi người ghé qua xem bài và cho nhận xét, góp ý.
Trân trọng.
 
Upvote 0
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

H
Có thể mở file Excel mới sẽ Zoom mặc định 150% không?
Trả lời
4
Đọc
147
VetMini
V
T
Đánh Số Thứ Tự Loại Bỏ Trùng
Trả lời
0
Đọc
3
Trang Tuyet Ngoc Nhi
T
O
  • Question
Tìm số thứ tự của sheet trong workbook có nhiều sheets
Trả lời
11
Đọc
3K
VetMini
V
Manhhung90
Liệt kê các ngày cộng dồn mong muốn vào 1 ô. Nhờ mọi người giúp mình ạ.
2 3 4
Trả lời
62
Đọc
737
VetMini
V
C
Hàm đánh số thứ tự như không đánh dữ liệu trùng
Trả lời
7
Đọc
8K
Trang Tuyet Ngoc Nhi
T
H
  • Question
Xóa toàn bộ các dòng giống nhau ở 1 cột
    • Cười
Trả lời
8
Đọc
58
hadoan-pap
H
Hai Lúa Miền Tây
  • Question
Hàm chuyển dữ liệu từ cột sang dòng (Hàm melt + wide_to_long của Python trong Excel)
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
9
Đọc
456
tranhungdao12a3
T
GPE-Trợ Lý
Đăng ký tham dự hội thảo tại Hà Nội: Power Query - Công cụ quản lý dữ liệu
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
4
Đọc
456
PhanTuHuong
PhanTuHuong
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
7 8 9
Trả lời
163
Đọc
8K
trannguyen197
T
vova2209
  • Question
Tìm địa chỉ ô với 2đk và chuyển thành links
Trả lời
12
Đọc
205
vova2209
vova2209
tvcneo
  • Question
Nhờ Anh Chị Em giúp mình cách để tạo macro giống như trong file này
Trả lời
17
Đọc
221
huuthang_bd
huuthang_bd
T
Có phải lỗi Excel?
Trả lời
8
Đọc
9K
dinhthang8709
D
T
Công thức lấy dữ liệu
Trả lời
3
Đọc
116
HUONGHCKT
H
S
  • Question
Nhờ anh chị giúp em hàm ngẫu nhiên với tổng là 1 số
Trả lời
6
Đọc
150
SA_DQ
SA_DQ
L
Tự động nhảy số tham chiếu khi sang sheet mới
Trả lời
5
Đọc
5K
Romantic92
R
TieuLong2708
Danh sách lịch cắt người trực
Trả lời
0
Đọc
36
TieuLong2708
TieuLong2708
C
  • Question
Xin giúp đỡ Code kiểm tra và copy dữ liệu từ sheet 1 sang sheet 2
2
Trả lời
21
Đọc
627
conan1
C
H
  • Question
Mong giúp code chuyển file xls sang xlsx hàng loạt và không lỗi số liệu
Trả lời
16
Đọc
370
Hoàng Tuấn 868
H
jenny12345
tổng hợp dữ liệu theo tháng
Trả lời
10
Đọc
247
Hoàng Tuấn 868
H
S
Trợ giúp công thức lấy dữ liệu
Trả lời
7
Đọc
134
Hoàng Tuấn 868
H
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

Back
Top Bottom