Nhờ A/C giúp tạo ra bảng so sánh từ 2 bảng cho trước

Liên hệ QC
doveandrose

doveandrose

hello
Tham gia
3/7/09
Bài viết
2,375
Được thích
2,264
Như tiêu đề nhờ các A/C giúp em có gửi file đính kèm
 

File đính kèm

  • so sanh.xlsm
    8.7 KB · Đọc: 34
Sắp xếp theo thời gian sắp xếp theo bầu chọn
bài này đã vi phạm nội quy hay nó quá đơn giản nên ko có ai trả lời nhỉ . mong các A/C cho biết để e có định hướng
 
Upvote 0
doveandrose đã viết:
Như tiêu đề nhờ các A/C giúp em có gửi file đính kèm
Nhấp chuột vào đây để mở rộng...
PHP: 
Sub taobangsosanh()
Dim Ar1(), Ar2(), i, j, k, x, res()
Ar1 = Range("A3", [B65536].End(3)).Value
Ar2 = Range("D3", [E65536].End(3)).Value
ReDim res(1 To UBound(Ar1) + UBound(Ar2), 1 To 3)
With CreateObject("scripting.dictionary")
   For i = 1 To UBound(Ar1)
      If Not .exists(Ar1(i, 1)) Then
         k = k + 1
         .Add Ar1(i, 1), k
         res(k, 1) = Ar1(i, 1)
         res(k, 2) = Ar1(i, 2)
      Else
         x = .Item(Ar1(i, 1))
         res(x, 2) = res(x, 2) + Ar1(i, 2)
      End If
   Next
   For i = 1 To UBound(Ar2)
      If Not .exists(Ar2(i, 1)) Then
         k = k + 1
         .Add Ar2(i, 1), k
         res(k, 1) = Ar2(i, 1)
         res(k, 3) = Ar2(i, 2)
      Else
         x = .Item(Ar2(i, 1))
         res(x, 3) = res(x, 3) + Ar2(i, 2)
      End If
   Next
End With
[H3].Resize(k, 3) = res
[H3].Resize(k, 3).Sort [H2]
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Mượn code của anh Hải để viết lại Module rút gọn có thể áp dụng cho nhiều bảng
module lấy dữ liệu cho từng bảng riêng biệt
Mã: 
Sub SoSanh(ByRef Dic As Object, Arr(), Res(), ByRef k As Long, ByRef Tong_Tung_Ban As Byte)
    Dim i, j, x
        For i = 1 To UBound(Arr)
           If Not Dic.exists(Arr(i, 1)) Then
              k = k + 1
              Dic.Add Arr(i, 1), k
              Res(k, 1) = Arr(i, 1)
              Res(k, Tong_Tung_Ban) = Arr(i, 2)
           Else
              x = Dic.Item(Arr(i, 1))
              Res(x, Tong_Tung_Ban) = Res(x, Tong_Tung_Ban) + Arr(i, 2)
           End If
        Next
            Tong_Tung_Ban = Tong_Tung_Ban + 1
End Sub
Module cho chương trình chính, chỉ gọi ra và truyền tham số là được
Mã: 
Sub GPE()
    Dim Dic As Object
    Dim Arr1(), Arr2(), k As Long, x, Res()
    Dim Tong_Tung_Ban As Byte
        Arr1 = Range("A3", [B65536].End(3)).Value
        Arr2 = Range("D3", [E65536].End(3)).Value
        ReDim Res(1 To UBound(Arr1) + UBound(Arr2), 1 To 3)
        k = 0
        Set Dic = CreateObject("Scripting.Dictionary")
        Tong_Tung_Ban = 2
        Call SoSanh(Dic, [COLOR=#ff0000][B]Arr1[/B][/COLOR], Res, k, Tong_Tung_Ban)
        Call SoSanh(Dic,[COLOR=#ff0000][B] Arr2[/B][/COLOR], Res, k, Tong_Tung_Ban)
        [K3].Resize(k, [B]Tong_Tung_Ban-1[/B]) = Res
        [K3].Resize(k, [B]Tong_Tung_Ban-1[/B]).Sort [K2]


End Sub
Code này đang ở dạng thô sơ, chưa có bẫy lỗi và tinh chỉnh lại định dạng
 
Lần chỉnh sửa cuối:
Upvote 0
phihndhsp đã viết:
Mượn code của anh Hải để viết lại Module rút gọn có thể áp dụng cho nhiều bảng
module lấy dữ liệu cho từng bảng riêng biệt
Mã: 
Sub SoSanh(ByRef Dic As Object, Arr(), Res(), ByRef k As Long, ByRef Tong_Tung_Ban As Byte)
    Dim i, j, x
        For i = 1 To UBound(Arr)
           If Not Dic.exists(Arr(i, 1)) Then
              k = k + 1
              Dic.Add Arr(i, 1), k
              Res(k, 1) = Arr(i, 1)
              Res(k, Tong_Tung_Ban) = Arr(i, 2)
           Else
              x = Dic.Item(Arr(i, 1))
              Res(x, Tong_Tung_Ban) = Res(x, Tong_Tung_Ban) + Arr(i, 2)
           End If
        Next
            Tong_Tung_Ban = Tong_Tung_Ban + 1
End Sub
Module cho chương trình chính, chỉ gọi ra và truyền tham số là được
Mã: 
Sub GPE()
    Dim Dic As Object
    Dim Arr1(), Arr2(), k As Long, x, Res()
    Dim Tong_Tung_Ban As Byte
        Arr1 = Range("A3", [B65536].End(3)).Value
        Arr2 = Range("D3", [E65536].End(3)).Value
        ReDim Res(1 To UBound(Arr1) + UBound(Arr2), 1 To 3)
        k = 0
        Set Dic = CreateObject("Scripting.Dictionary")
        Tong_Tung_Ban = 2
        Call SoSanh(Dic, [COLOR=#ff0000][B]Arr1[/B][/COLOR], Res, k, Tong_Tung_Ban)
        Call SoSanh(Dic,[COLOR=#ff0000][B] Arr2[/B][/COLOR], Res, k, Tong_Tung_Ban)
        [K3].Resize(k, [B]Tong_Tung_Ban-1[/B]) = Res
        [K3].Resize(k, [B]Tong_Tung_Ban-1[/B]).Sort [K2]


End Sub
Code này đang ở dạng thô sơ, chưa có bẫy lỗi và tinh chỉnh lại định dạng
Nhấp chuột vào đây để mở rộng...

Lỡ như có 100 bảng thì sao hả Phi? Hỏng lẻ Call 100 lần à? Đã rút gọn thì Call 1 lần thôi chứ. Đây mới gọi là thuật toán nè. Thử giải bài theo hướng có 100 bảng xem sao.
 
Upvote 0
Cái quang trọng là đầu vào là như thế nào thôi anh hải, vì khi gọi hàm chỉ có các bảng thay đổi thông qua các arr1, arr2, arr3. Không biết có thể làm như sau được không. Tạo một kiểu struct mới sau đó tạo ra biến arr kiểu struct rồi áp dụng, đó là ý tưởng và sẽ bắt tay vào thử cái đã
 
Lần chỉnh sửa cuối:
Upvote 0
phihndhsp đã viết:
Cái quang trọng là đầu vào là như thế nào thôi anh hải, vì khi gọi hàm chỉ có các bảng thay đổi thông qua các arr1, arr2, arr3.
Nhấp chuột vào đây để mở rộng...
Nhưng mình chỉ muốn gọi Call 1 lần thôi. Tạm thời dựa vào dữ liệu hiện tại và mình muốn Call 1 lần duy nhất. Gọi 2 lần hay 100 lần cũng giống nhau. Đây mới là tuyệt chiêu đấy.
 
Upvote 0
Để em thử sức mình xem sao?
 
Upvote 0
quanghai1969 đã viết:
Nhưng mình chỉ muốn gọi Call 1 lần thôi. Tạm thời dựa vào dữ liệu hiện tại và mình muốn Call 1 lần duy nhất. Gọi 2 lần hay 100 lần cũng giống nhau. Đây mới là tuyệt chiêu đấy.
Nhấp chuột vào đây để mở rộng...
Anh Hải có thể chỉ dẫn để cho em và các bạn khác học hỏi được không?
 
Upvote 0
phihndhsp đã viết:
Anh Hải có thể chỉ dẫn để cho em và các bạn khác học hỏi được không?
Nhấp chuột vào đây để mở rộng...
Đúng là mần như cách anh NDU gợi ý. Thật ra ta cũng phai gọi Call nhiều lần nhưng mà gọi qua vòng lặp để cho code gọn thôi. Chứ nói kiểu gọi 1 lần thì có hơi quá đáng thì phải!
 
Upvote 0
ndu96081631 đã viết:
Thử dùng ParamArray cho mảng đầu vào xem
(chưa thử nhưng đoán là được)
Nhấp chuột vào đây để mở rộng...
Mã: 
Sub SoSanh(ByRef Dic As Object, Res(), ByRef k As Long, ByRef Tong_Tung_Ban As Byte, ParamArray sArray() As Variant)    
    Dim i, j, x
    Dim Arr
    For Each Arr In sArray
         
        For i = 1 To UBound(Arr)
           If Not Dic.exists(Arr(i, 1)) Then
              k = k + 1
              Dic.Add Arr(i, 1), k
              Res(k, 1) = Arr(i, 1)
              Res(k, Tong_Tung_Ban) = Arr(i, 2)
           Else
              x = Dic.Item(Arr(i, 1))
              Res(x, Tong_Tung_Ban) = Res(x, Tong_Tung_Ban) + Arr(i, 2)
           End If
        Next
            Tong_Tung_Ban = Tong_Tung_Ban + 1
     Next
End Sub
Mã: 
Sub GPE()
    Dim Dic As Object
    Dim Arr1(), Arr2(), k As Long, x, Res()
    Dim Tong_Tung_Ban As Byte
        Arr1 = Range("A3", [B65536].End(3)).Value
        Arr2 = Range("D3", [E65536].End(3)).Value
        ReDim Res(1 To UBound(Arr1) + UBound(Arr2), 1 To 3)
        k = 0
        Set Dic = CreateObject("Scripting.Dictionary")
        Tong_Tung_Ban = 2
        Call SoSanh(Dic, Res, k, Tong_Tung_Ban, Arr1, Arr2)
        [K3].Resize(k, Tong_Tung_Ban - 1) = Res
        [K3].Resize(k, Tong_Tung_Ban - 1).Sort [K2]
End Sub
Học hỏi thêm được cái mới Cảm ơn Anh Ndu chỉ đường cho đi
 
Lần chỉnh sửa cuối:
Upvote 0
phihndhsp đã viết:
Mã: 
Sub SoSanh(ByRef Dic As Object, Res(), ByRef k As Long, ByRef Tong_Tung_Ban As Byte, ParamArray sArray() As Variant)    
    Dim i, j, x
    Dim Arr
    For Each Arr In sArray
         
        For i = 1 To UBound(Arr)
           If Not Dic.exists(Arr(i, 1)) Then
              k = k + 1
              Dic.Add Arr(i, 1), k
              Res(k, 1) = Arr(i, 1)
              Res(k, Tong_Tung_Ban) = Arr(i, 2)
           Else
              x = Dic.Item(Arr(i, 1))
              Res(x, Tong_Tung_Ban) = Res(x, Tong_Tung_Ban) + Arr(i, 2)
           End If
        Next
            Tong_Tung_Ban = Tong_Tung_Ban + 1
     Next
End Sub
Mã: 
Sub GPE()
    Dim Dic As Object
    Dim Arr1(), Arr2(), k As Long, x, Res()
    Dim Tong_Tung_Ban As Byte
        Arr1 = Range("A3", [B65536].End(3)).Value
        Arr2 = Range("D3", [E65536].End(3)).Value
        ReDim Res(1 To UBound(Arr1) + UBound(Arr2), 1 To 3)
        k = 0
        Set Dic = CreateObject("Scripting.Dictionary")
        Tong_Tung_Ban = 2
        Call SoSanh(Dic, Res, k, Tong_Tung_Ban, Arr1, Arr2)
        [K3].Resize(k, Tong_Tung_Ban - 1) = Res
        [K3].Resize(k, Tong_Tung_Ban - 1).Sort [K2]
End Sub
Học hỏi thêm được cái mới Cảm ơn Anh Ndu chỉ đường cho đi
Nhấp chuột vào đây để mở rộng...
Làm khó nhau tí nha. Giờ mình có tới cả 100 bảng cơ. Nhưng mình không muốn tạo Arr1, Arr2... Arr100 đâu.
 
Upvote 0
quanghai1969 đã viết:
Làm khó nhau tí nha. Giờ mình có tới cả 100 bảng cơ. Nhưng mình không muốn tạo Arr1, Arr2... Arr100 đâu.
Nhấp chuột vào đây để mở rộng...
ok anh. chủ yếu là học hỏi để nâng cao kiến thức thôi, có như vậy mới thấy mình phát triển thêm được, mục đích của em là ráng ráng để dưới tầm anh Ndu một tí thôi
 
Upvote 0
quanghai1969 đã viết:
Làm khó nhau tí nha. Giờ mình có tới cả 100 bảng cơ. Nhưng mình không muốn tạo Arr1, Arr2... Arr100 đâu.
Nhấp chuột vào đây để mở rộng...
Theo file đính kèm ở bài 101, do anh Hải yêu cầu code ngắn nên tốc độ sẽ chậm do phải copy paste.
Mã: 
Sub xxx()
    Dim n&, Hang&, Cot&, i&, j&, k&, R As Range, arr(), kq()
    Set R = Range("XFD2").End(xlToLeft)
    n = Val(Right(R.Text, Len(R.Text) - 5))
    Cot = R.Column - n
    Hang = 3
    For i = 1 To n
        Set R = R.End(xlToLeft).End(xlToLeft)
        Range(R.Offset(1, -1), R.Offset(, -1).End(xlDown)).Copy Cells(Hang, Cot)
        Range(R.Offset(1), R.End(xlDown)).Copy Cells(Hang, Cot + n - i + 1)
        Hang = Hang + R.End(xlDown).Row - 2
    Next
    Set R = Range(Cells(3, Cot), Cells(Hang - 1, Cot + n))
    R.Sort Cells(3, Cot)
    arr = R
    ReDim kq(1 To UBound(arr), 1 To UBound(arr, 2))
    k = 1
    kq(1, 1) = arr(1, 1)
    For i = 1 To UBound(arr)
        If arr(i, 1) <> kq(k, 1) Then
                k = k + 1
                kq(k, 1) = arr(i, 1)
        End If
        For j = 2 To n + 1
            kq(k, j) = arr(i, j) + kq(k, j)
        Next
    Next
    R.ClearContents
    R.Resize(k) = kq
End Sub
 
Upvote 0
Hau151978 đã viết:
Theo file đính kèm ở bài 101, do anh Hải yêu cầu code ngắn nên tốc độ sẽ chậm do phải copy paste.
Mã: 
Sub xxx()
    Dim n&, Hang&, Cot&, i&, j&, k&, R As Range, arr(), kq()
    Set R = Range("XFD2").End(xlToLeft)
    n = Val(Right(R.Text, Len(R.Text) - 5))
    Cot = R.Column - n
    Hang = 3
    For i = 1 To n
        Set R = R.End(xlToLeft).End(xlToLeft)
        Range(R.Offset(1, -1), R.Offset(, -1).End(xlDown)).Copy Cells(Hang, Cot)
        Range(R.Offset(1), R.End(xlDown)).Copy Cells(Hang, Cot + n - i + 1)
        Hang = Hang + R.End(xlDown).Row - 2
    Next
    Set R = Range(Cells(3, Cot), Cells(Hang - 1, Cot + n))
    R.Sort Cells(3, Cot)
    arr = R
    ReDim kq(1 To UBound(arr), 1 To UBound(arr, 2))
    k = 1
    kq(1, 1) = arr(1, 1)
    For i = 1 To UBound(arr)
        If arr(i, 1) <> kq(k, 1) Then
                k = k + 1
                kq(k, 1) = arr(i, 1)
        End If
        For j = 2 To n + 1
            kq(k, j) = arr(i, j) + kq(k, j)
        Next
    Next
    R.ClearContents
    R.Resize(k) = kq
End Sub
Nhấp chuột vào đây để mở rộng...
Cũng là 1 cách hay, nhưng mình lại đang nghĩ đến 1 cách khác chỉ 2 vòng For thôi.
 
Upvote 0
quanghai1969 đã viết:
Cũng là 1 cách hay, nhưng mình lại đang nghĩ đến 1 cách khác chỉ 2 vòng For thôi.
Nhấp chuột vào đây để mở rộng...
Nếu bớt 1 vòng for thì lại phải dùng Dictionary cũng vậy:
Mã: 
Sub xyz()
    Dim n&, Cot&, i&, j&, k&, R As Range, arr(), kq()
    Dim dic As New Dictionary
    Set R = Range("XFD2").End(xlToLeft)
    n = Val(Right(R.Text, Len(R.Text) - 5))
    Cot = R.Column - n
    ReDim kq(1 To 1000000, 1 To n + 1)
    For i = n To 1 Step -1
        Set R = R.End(xlToLeft).End(xlToLeft)
        arr = Range(R.Offset(1, -1), R.End(xlDown))
        For j = 1 To UBound(arr)
            If Not dic.Exists(arr(j, 1)) Then
                k = k + 1
                dic.Add arr(j, 1), k
                kq(k, 1) = arr(j, 1)
            End If
            kq(dic.Item(arr(j, 1)), i + 1) = kq(dic.Item(arr(j, 1)), i + 1) + arr(j, 2)
        Next
    Next
    Cells(3, Cot).Resize(k, n + 1) = kq
End Sub
 
Lần chỉnh sửa cuối:
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

doandat92
Tách chữ in đậm
Trả lời
5
Đọc
10
senna
senna
T
Tổng hợp từ Sheet1 qua Sheet2
Trả lời
4
Đọc
63
thaiquy7
T
ann266
Kế toán kho F&B
    • Cười
Trả lời
11
Đọc
121
doandat92
doandat92
senna
  • Question
Xin giúp đỡ tổng hợp dữ liệu từ nhiều file vào 1 file mà không cần mở file
Trả lời
0
Đọc
20
senna
senna
V
  • Question
GIúp code xóa các tên mặt hàng trùng nhau, chỉ chừa lại tên cho dòng trên cùng
Trả lời
10
Đọc
295
Phan Thế Hiệp
Phan Thế Hiệp
Xem thêm…

Facebook

Giaiphapexcel.com

Group

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

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