So sánh dữ liệu giữa 2 mảng

Liên hệ QC
vanaccex

vanaccex

Thành viên tiêu biểu
Tham gia
8/7/18
Bài viết
454
Được thích
305
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

  • So sanh giua 2 mang.xlsx
    11.8 KB · Đọc: 48
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 ạ !
 
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ã: 
Public Sub GPE()
Dim I As Long, Arr1, Arr2, kArr, K As Long, Dic As Object, Rw As Long
Set Dic = CreateObject("Scripting.Dictionary")

Arr1 = Range("A4:C8").Value
Arr2 = Range("F4:H8").Value

ReDim kArr(1 To UBound(Arr1) + UBound(Arr2), 1 To 7)
    
    For I = 1 To (UBound(Arr1))
        If Len(Arr1(I, 1)) Then
            If Not Dic.exists(Arr1(I, 1)) Then
                K = K + 1
                Dic.Add Arr1(I, 1), K
                kArr(K, 1) = Arr1(I, 1)
                kArr(K, 2) = Arr1(I, 2)
                kArr(K, 4) = "=RC[-2]-RC[-1]"
                kArr(K, 5) = Arr1(I, 3)
                kArr(K, 7) = "=RC[-2]-RC[-1]"
            End If
        End If
    Next
    
    For I = 1 To UBound(Arr2)
        If Len(Arr2(I, 1)) Then
            If Not Dic.exists(Arr2(I, 1)) Then
                K = K + 1
                Dic.Add Arr2(I, 1), K
                kArr(K, 1) = Arr2(I, 1)
                kArr(K, 3) = Arr2(I, 2)
                kArr(K, 4) = "=RC[-2]-RC[-1]"
                kArr(K, 6) = Arr2(I, 3)
                kArr(K, 7) = "=RC[-2]-RC[-1]"
            Else
                Rw = Dic.Item(Arr2(I, 1))
                kArr(Rw, 3) = Arr2(I, 2)
                kArr(Rw, 6) = Arr2(I, 3)
            End If
        End If
    Next
If K Then Range("A22").Resize(K, 7).Value = kArr
End Sub
 
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

  • So sanh 2 mang.xlsx
    11.8 KB · Đọc: 9
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

V
Tìm điều kiện sau đó tính tổng ma hang theo điều kiện
Trả lời
2
Đọc
9
BuiQuangThuan
B
phanmoi688
[Xin nhờ giúp đỡ] Tìm cách xóa các ký tự trắng trong biểu
Trả lời
0
Đọc
9
phanmoi688
phanmoi688
phanmoi688
[Xin nhờ giúp đỡ] Cách đối chiếu dữ liệu giữa hai biểu
    • Thích
2
Trả lời
26
Đọc
353
phanmoi688
phanmoi688
V
  • Question
Tìm kiếm và copy giá trị từ bảng đến bảng khác
Trả lời
8
Đọc
172
vnproc
V
N
Em cần giúp tách số thập phân trong chuỗi trên file excel
Trả lời
3
Đọc
48
Duy Tùng 9x
Duy Tùng 9x
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

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