So sánh dữ liệu giữa 2 mảng (3 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
vanaccex

vanaccex

Thành viên tiêu biểu
Tham gia
8/7/18
Bài viết
457
Được thích
306
Giới tính
Nữ
Em có 2 mảng dữ lieu Gồm mảng 1 và mảng 2 như trong File và kết quả mong muốn so sánh giữa 2 file này. Em mong anh (chị) trong diễn đàn giúp đỡ bang vba vơới
 

File đính kèm

vanaccex đã viết:
Em có 2 mảng dữ lieu Gồm mảng 1 và mảng 2 như trong File và kết quả mong muốn so sánh giữa 2 file này. Em mong anh (chị) trong diễn đàn giúp đỡ bang vba vơới
Nhấp chuột vào đây để mở rộng...
Mã: 
Sub AA()
    Dim cn As Object, query As String
    query = "select a.f1, a.f2, b.f2, iif(a.f2 is null,0, a.f2) - iif(b.f2 is null,0, b.f2), a.f3, b.f3, iif(a.f3 is null,0, a.f3) - iif(b.f3 is null,0, b.f3) from [A4:C7] a inner join [F4:H8] b on b.f1 = a.f1 and (a.f2 <> b.f2 or a.f3 <> b.f3)" & _
    " union select a.f1, a.f2, b.f2, iif(a.f2 is null,0, a.f2) - iif(b.f2 is null,0, b.f2), a.f3, b.f3, iif(a.f3 is null,0, a.f3) - iif(b.f3 is null,0, b.f3) from [A4:C7] a left join [F4:H8] b on b.f1 = a.f1 where b.f1 is null" & _
    " union select a.f1, b.f2, a.f2, iif(b.f2 is null,0, b.f2) - iif(a.f2 is null,0, a.f2), b.f3, a.f3, iif(b.f3 is null,0, b.f3) - iif(a.f3 is null,0, a.f3) from [F4:H8] a left join [A4:C7] b on b.f1 = a.f1 where b.f1 is null"
    Set cn = CreateObject("ADODB.Connection")
    cn.Open ("Provider=Microsoft.ace.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1"";")
    Range("K4").CopyFromRecordset cn.Execute(query)
    Set cn = Nothing
End Sub
 
Em ko biết cách này
Bài đã được tự động gộp:

Nếu dùng mảng và từ điển thì sẽ theo hướng nào anh nhỉ ? Em Cảm ơn anh ạ !
 
Lần chỉnh sửa cuối:
vanaccex đã viết:
Em ko biết cách này
Bài đã được tự động gộp:

Nếu dùng mảng và từ điển thì sẽ theo hướng nào anh nhỉ
Nhấp chuột vào đây để mở rộng...
Khó giải thích với bạn, nên đưa luôn code
Mã: 
Sub bb()
    Dim dic As Object, dar(1 To 1000, 1 To 8), kq(1 To 1000, 1 To 7), i, j, k, n
    Set dic = CreateObject("Scripting.Dictionary")
    With dic
        ar = Range("A4:C7")
        For i = 1 To UBound(ar)
            If Not .exists(ar(i, 1)) Then
                k = k + 1
                .Add ar(i, 1), k
                dar(k, 1) = ar(i, 1)
                dar(k, 2) = ar(i, 2)
                dar(k, 5) = ar(i, 3)
                dar(k, 4) = ar(i, 2)
                dar(k, 7) = ar(i, 3)
            End If
        Next
        ar = Range("F4:H8")
        For i = 1 To UBound(ar)
            If Not .exists(ar(i, 1)) Then
                k = k + 1
                .Add ar(i, 1), k
                dar(k, 1) = ar(i, 1)
                dar(k, 3) = ar(i, 2)
                dar(k, 6) = ar(i, 3)
                dar(k, 4) = -ar(i, 2)
                dar(k, 7) = -ar(i, 3)
            Else
                If ar(i, 2) = dar(.Item(ar(i, 1)), 2) And ar(i, 3) = dar(.Item(ar(i, 1)), 5) Then
                    dar(.Item(ar(i, 1)), 8) = "x"
                Else
                    dar(.Item(ar(i, 1)), 3) = ar(i, 2)
                    dar(.Item(ar(i, 1)), 6) = ar(i, 3)
                    dar(.Item(ar(i, 1)), 4) = dar(.Item(ar(i, 1)), 2) - ar(i, 2)
                    dar(.Item(ar(i, 1)), 7) = dar(.Item(ar(i, 1)), 5) - ar(i, 3)
                End If
            End If
        Next
    End With
    For i = 1 To k
        If dar(i, 8) <> "x" Then
            n = n + 1
            For j = 1 To 7
                kq(n, j) = dar(i, j)
            Next
        End If
    Next
    Range("K4").Resize(n, 7) = kq
End Sub
 
quanluu1989 đã viết:
Khó giải thích với bạn, nên đưa luôn code
Mã: 
Sub bb()
    Dim dic As Object, dar(1 To 1000, 1 To 8), kq(1 To 1000, 1 To 7), i, j, k, n
    Set dic = CreateObject("Scripting.Dictionary")
    With dic
        ar = Range("A4:C7")
        For i = 1 To UBound(ar)
            If Not .exists(ar(i, 1)) Then
                k = k + 1
                .Add ar(i, 1), k
                dar(k, 1) = ar(i, 1)
                dar(k, 2) = ar(i, 2)
                dar(k, 5) = ar(i, 3)
                dar(k, 4) = ar(i, 2)
                dar(k, 7) = ar(i, 3)
            End If
        Next
        ar = Range("F4:H8")
        For i = 1 To UBound(ar)
            If Not .exists(ar(i, 1)) Then
                k = k + 1
                .Add ar(i, 1), k
                dar(k, 1) = ar(i, 1)
                dar(k, 3) = ar(i, 2)
                dar(k, 6) = ar(i, 3)
                dar(k, 4) = -ar(i, 2)
                dar(k, 7) = -ar(i, 3)
            Else
                If ar(i, 2) = dar(.Item(ar(i, 1)), 2) And ar(i, 3) = dar(.Item(ar(i, 1)), 5) Then
                    dar(.Item(ar(i, 1)), 8) = "x"
                Else
                    dar(.Item(ar(i, 1)), 3) = ar(i, 2)
                    dar(.Item(ar(i, 1)), 6) = ar(i, 3)
                    dar(.Item(ar(i, 1)), 4) = dar(.Item(ar(i, 1)), 2) - ar(i, 2)
                    dar(.Item(ar(i, 1)), 7) = dar(.Item(ar(i, 1)), 5) - ar(i, 3)
                End If
            End If
        Next
    End With
    For i = 1 To k
        If dar(i, 8) <> "x" Then
            n = n + 1
            For j = 1 To 7
                kq(n, j) = dar(i, j)
            Next
        End If
    Next
    Range("K4").Resize(n, 7) = kq
End Sub
Nhấp chuột vào đây để mở rộng...
Em cảm ơn anh nhiều ạ
 
vanaccex đã viết:
Em ko biết cách này
Bài đã được tự động gộp:

Nếu dùng mảng và từ điển thì sẽ theo hướng nào anh nhỉ ? Em Cảm ơn anh ạ !
Nhấp chuột vào đây để mở rộng...
Mã: 
Sub Test_()
    Dim i As Long, Arr(), Arr2(), Arr3(), Res(), k As Long, x As Long
    Arr2 = Range("A4:C8").Value
    Arr3 = Range("F4:H8").Value
    ReDim Arr(1 To UBound(Arr3, 1) + UBound(Arr2, 1), 1 To UBound(Arr3, 2))
        For x = 1 To (UBound(Arr2))
            Arr(x, 1) = Arr2(x, 1)
            Arr(x, 2) = Arr2(x, 2)
            Arr(x, 3) = Arr2(x, 3)
            Arr(x + UBound(Arr2), 1) = Arr3(x, 1)
            Arr(x + UBound(Arr2), 2) = Arr3(x, 2)
            Arr(x + UBound(Arr2), 3) = Arr3(x, 3)
        Next x
    ReDim Res(1 To UBound(Arr, 1), 1 To (UBound(Arr2, 2) + UBound(Arr3, 2) + 2))
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(Arr)
            If Len(Arr(i, 1)) Then
                If Not .exists(Arr(i, 1)) Then
                    k = k + 1
                    .Add Arr(i, 1), k
                    Res(k, 1) = Arr(i, 1)
                    If i <= UBound(Arr2) Then
                    Res(k, 2) = Arr2(i, 2)
                    Res(k, 5) = Arr2(i, 3)
                    Else
                    Res(k, 3) = Arr3(i - UBound(Arr2), 2)
                    Res(k, 6) = Arr3(i - UBound(Arr2), 3)
                    End If
                Else
                    x = .Item(Arr(i, 1))
                    If i <= UBound(Arr2) Then
                    Res(x, 2) = Arr2(i, 2)
                    Res(x, 5) = Arr2(i, 3)
                    Else
                    Res(x, 3) = Arr3(i - UBound(Arr2), 2)
                    Res(x, 6) = Arr3(i - UBound(Arr2), 3)
                    End If
                End If
            End If
        Next
        For i = 1 To UBound(Res)
            Res(i, 4) = Res(i, 2) - Res(i, 3)
            Res(i, 7) = Res(i, 5) - Res(i, 6)
        Next
        
        Range("A22").Resize(k, 7) = Res

    End With
End Sub
 
Hay quá ạ !. Em cảm ơn các anh ạ !
 
Anh (Chị ) có thể cho em hỏi nếu như File dữ liệu của em ở bảng tính 1 và bảng tính 2 là dữ liệu ở cột Điều kiện là không duy nhất, Em Muốn Cộng tổng trước khi so sánh giá trị này thì sẽ sửa code trên như thế nào ạ ?. Em cảm ơn anh (chị ) ạ. Em mượn file của chị @vanaccex ở trên để biểu thị dữ liệu File của em ạ !
 

File đính kèm

vanvan9697 đã viết:
Anh (Chị ) có thể cho em hỏi nếu như File dữ liệu của em ở bảng tính 1 và bảng tính 2 là dữ liệu ở cột Điều kiện là không duy nhất, Em Muốn Cộng tổng trước khi so sánh giá trị này thì sẽ sửa code trên như thế nào ạ ?. Em cảm ơn anh (chị ) ạ. Em mượn file của chị @vanaccex ở trên để biểu thị dữ liệu File của em ạ !
Nhấp chuột vào đây để mở rộng...
Bạn thử Code này:

PHP: 
Public Sub sGpe()
Dim Arr1(), Arr2(), dArr(), I As Long, K As Long, Rws As Long, R1 As Long, R2 As Long, Txt As String
Arr1 = Range("A4", Range("A4").End(xlDown)).Resize(, 3).Value
Arr2 = Range("F4", Range("F4").End(xlDown)).Resize(, 3).Value
R1 = UBound(Arr1): R2 = UBound(Arr2)
ReDim dArr(1 To R1 + R2, 1 To 10)
With CreateObject("Scripting.Dictionary")
    For I = 1 To R1
        Txt = Arr1(I, 1)
        If Not .Exists(Txt) Then
            K = K + 1
            .Item(Txt) = K
            dArr(K, 1) = Txt
            dArr(K, 2) = Arr1(I, 2)
            dArr(K, 5) = Arr1(I, 3)
        Else
            Rws = .Item(Txt)
            dArr(Rws, 2) = dArr(Rws, 2) + Arr1(I, 2)
            dArr(Rws, 5) = dArr(Rws, 5) + Arr1(I, 3)
        End If
    Next I
    '-------------------------------------
    For I = 1 To R2
        Txt = Arr2(I, 1)
        If Not .Exists(Txt) Then
            K = K + 1
            .Item(Txt) = K
            dArr(K, 1) = Txt
            dArr(K, 3) = Arr2(I, 2)
            dArr(K, 6) = Arr2(I, 3)
        Else
            Rws = .Item(Txt)
            dArr(Rws, 3) = dArr(Rws, 3) + Arr2(I, 2)
            dArr(Rws, 6) = dArr(Rws, 6) + Arr2(I, 3)
        End If
    Next I
End With
    '----------------------------------
    For I = 1 To K
        dArr(I, 4) = dArr(I, 3) - dArr(I, 2)
        dArr(I, 7) = dArr(I, 6) - dArr(I, 5)
    Next I
Range("A16").Resize(K, 7) = dArr
End Sub
 
Ba Tê đã viết:
Bạn thử Code này:

PHP: 
Public Sub sGpe()
Dim Arr1(), Arr2(), dArr(), I As Long, K As Long, Rws As Long, R1 As Long, R2 As Long, Txt As String
Arr1 = Range("A4", Range("A4").End(xlDown)).Resize(, 3).Value
Arr2 = Range("F4", Range("F4").End(xlDown)).Resize(, 3).Value
R1 = UBound(Arr1): R2 = UBound(Arr2)
ReDim dArr(1 To R1 + R2, 1 To 10)
With CreateObject("Scripting.Dictionary")
    For I = 1 To R1
        Txt = Arr1(I, 1)
        If Not .Exists(Txt) Then
            K = K + 1
            .Item(Txt) = K
            dArr(K, 1) = Txt
            dArr(K, 2) = Arr1(I, 2)
            dArr(K, 5) = Arr1(I, 3)
        Else
            Rws = .Item(Txt)
            dArr(Rws, 2) = dArr(Rws, 2) + Arr1(I, 2)
            dArr(Rws, 5) = dArr(Rws, 5) + Arr1(I, 3)
        End If
    Next I
    '-------------------------------------
    For I = 1 To R2
        Txt = Arr2(I, 1)
        If Not .Exists(Txt) Then
            K = K + 1
            .Item(Txt) = K
            dArr(K, 1) = Txt
            dArr(K, 3) = Arr2(I, 2)
            dArr(K, 6) = Arr2(I, 3)
        Else
            Rws = .Item(Txt)
            dArr(Rws, 3) = dArr(Rws, 3) + Arr2(I, 2)
            dArr(Rws, 6) = dArr(Rws, 6) + Arr2(I, 3)
        End If
    Next I
End With
    '----------------------------------
    For I = 1 To K
        dArr(I, 4) = dArr(I, 3) - dArr(I, 2)
        dArr(I, 7) = dArr(I, 6) - dArr(I, 5)
    Next I
Range("A16").Resize(K, 7) = dArr
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ đúng ý em rồi ạ !. Em cảm ơn anh ạ !
 
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

K
  • Question Question
nhờ ace giúp đỡ tự động filter và In hàng loạt từng mục trong piviot table (1 người xem)
Trả lời
5
Đọc
166
DeTong
D
thlpro
Cách lập Công thức tính số ngày nghỉ AL, ưu tiên tính 2024 trước rồi mới tính 2025
Trả lời
6
Đọc
90
ptm0412
ptm0412
N
Một ví dụ về XLL add-in: Tương tác với Google Gemini dưới dạng công thức bảng tính (1 người xem)
    • Thích
Trả lời
1
Đọc
169
thuytrangbp28
T
vsitcnh
Hỗ trợ công thức tính điểm dựa theo điều kiện.
Trả lời
17
Đọc
272
tle2003
T
G
Tách công thức ra khỏi chuỗi và tính kết quả?
2
Trả lời
22
Đọc
2K
gobi
gobi
Trungvt3
Công thức trả về định dạng không như mong muốn và viết phân số trong 1 ô.
Trả lời
5
Đọc
119
VetMini
V
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
16 17 18
Trả lời
346
Đọc
31K
Vandat1607
V
M
Xin giúp đỡ làm công thức điều kiện
Trả lời
2
Đọc
135
Hoangkhang01213
Hoangkhang01213
N
Khắc phục lỗi "The picture is too large and will be truncated"
Trả lời
10
Đọc
5K
tle2003
T
C
  • Question Question
Xin hỏi Cách viết chú thích trong vba hiển thị tiếng việt
Trả lời
4
Đọc
185
ongke0711
ongke0711
B
Xin giải pháp chống sửa, xóa dữ liệu đã nhập vào từ ngày hôm trước.
    • Thích
2
Trả lời
28
Đọc
7K
Hoàng Tuấn 868
H
G
Xin Code xóa Module.
Trả lời
8
Đọc
309
huhumalu
H
00029591
Cần hỗ trợ công thức tổng hợp dữ liệu không cần cột phụ Vlookup
Trả lời
3
Đọc
173
tle2003
T
D
  • Đã giải quyết
Quản lý email outlook qua VBA cần giúp đỡ
2
Trả lời
22
Đọc
590
nguyendang95
N
S
Mở 2 cửa sổ riêng biệt
2
Trả lời
30
Đọc
23K
sakuraluu
S
F
Nhập dấu . (chấm) ở bàn phím phụ không tự chuyển thành dấu , (phẩy)
Trả lời
16
Đọc
57K
tubaodn21
tubaodn21
PhanTuHuong
Sách Lập trình VBA trong AutoCAD đã có mặt
    • Thích
    • Yêu thích
2
Trả lời
21
Đọc
1K
PhanTuHuong
PhanTuHuong
L
Lỗi font khi convert từ pdf
Trả lời
3
Đọc
152
lamvu0677
L
GPE-Trợ Lý
[GPE] TALKSHOW: PHÂN TÍCH BÁO CÁO ĐỘ NHẠY SỬ DỤNG EXCEL SOLVER (1 người xem)
    • Thích
Trả lời
0
Đọc
2K
GPE-Trợ Lý
GPE-Trợ Lý
K
Xin dax tính tỷ trọng doanh thu
Trả lời
18
Đọc
815
SteveNguyen1991
S
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
TALK SHOW: CÙNG NHẢY LAM BA ĐA VỚI HÀM LAMBDA (λ) EXCEL 365
Back
Top Bottom