Ghép dữ liệu 2 sheets khác nhau theo nhiều điều kiện

Chào các anh chị!

Các anh chị có thể giúp em ghép dữ liệu cột 7 sheet F = cột 4 sheet I và 8 sheet F = cột 5 sheet I theo đúng điều kiện cả cột 2, 3, 4 sheet F = cột 1, 2, 3 sheet I.

Dữ liệu của em thuộc dạng big data.
Em mới học được VBA 2 tuần và thầy giáo yêu cầu phải dùng VBA chứ không dùng hàm Excel.

Em xin cảm ơn nhiều!

File của em:

Bạn cần đăng nhập để thấy hình ảnh

Bạn cần đăng nhập để thấy hình ảnh
 

John Carter

Yêu THVBA
Mình chưa xem file. Nhưng nếu thầy giáo yêu cầu thì bạn vô phần VBA trong group để học từ từ rồi bị vướng chỗ nào mới đem lên hỏi. Hoặc xem kỹ lại kiến thức thầy giáo bạn dạy rồi áp dụng thôi. :) mấy bạn trên này xài cách cao siêu thì lại k đúng ý thầy bạn :)
 
D

Deleted member 1392

Guest
Bạn thử dùng hàm như bình thường nhưng ở dạng WorksheetFunction xem sao, vẫn VBA như ý thầy bạn :p
 
@John Carter

Mình chưa xem file. Nhưng nếu thầy giáo yêu cầu thì bạn vô phần VBA trong group để học từ từ rồi bị vướng chỗ nào mới đem lên hỏi. Hoặc xem kỹ lại kiến thức thầy giáo bạn dạy rồi áp dụng thôi. :) mấy bạn trên này xài cách cao siêu thì lại k đúng ý thầy bạn :)
Hi bạn,

Thầy mình không dạy mình VBA mà chỉ yêu cầu mình tự học rồi match dữ liệu theo yêu cầu của thầy thôi.
Mình học về kinh tế, không chuyên về cái này nên với mình là hơi khó. Mình đã thử tự đọc và thử viết nhưng code không chạy và thời gian cũng gấp gáp, bạn có thể giúp mình được không?

Cảm ơn bạn!

@Ngày Mới

Bạn thử dùng hàm như bình thường nhưng ở dạng WorksheetFunction xem sao, vẫn VBA như ý thầy bạn :p
Mình đã thử rồi nhưng không được bạn ạ.

Cảm ơn bạn!
 
H

haokira

Guest
@dieulinhdieulinh File bạn ác thật, nhìn thì tưởng cột A sheet I và cột B sheet F là kiểu dữ liệu giống nhau, ai dè bạn fomat lừa mắt. =))
 

dieulinhneu96

Yêu THVBA
@haokira

Hi bạn, vì format về ngày khác nhau nên mình đã tách ra thành các cột yy, mm, dd rồi ạ.
Bạn có thể giúp mình ghép dữ liệu cột Index level và hk-return ở 2 sheets F và I ( cột 10 sheet F = cột 7 sheet I và cột 11 sheet F = cột 8 sheet I) theo đúng điều kiện cả cột yy,m, dd, hh,mm ở 2 sheets F và I khớp nhau được không ạ?

Hình mình họa và file đình kèm mình có đăng ở đây ạ, sao cho thông tin của sheet I và sheet F match nhau ạ.

Cảm ơn bạn!

Bạn cần đăng nhập để thấy hình ảnh


(hình minh họa)

Bạn cần đăng nhập để thấy hình ảnh


Bạn cần đăng nhập để thấy hình ảnh


 
H

haokira

Guest
@dieulinhdieulinh
Mình tay ngang nên code rất thô, thời gian chạy rất rất lâu. Với dữ liệu 1000 dòng sheetF đã mất tầm 4s, mà nếu 2000 dòng thì là 15s =)). Bạn có thể tham khảo tạm. Tính đúng sai mình chưa test nhé :D

Mã:
Sub abc()
On Error Resume Next
Dim Tm As Double
Tm = Timer()
Dim tmpF, tmpI() '------------Khai bao bien
Dim ArrKq(1 To 65000, 1 To 2)
Dim i, k, m As Long
Dim dkF, dkI, dkI1 As String
Dim dkbs, dkbs1 As String
'--------------Xac dinh mang doi chieu
tmpF = Sheet2.Range("B2:F" & Sheet2.Range("B" & Rows.Count).End(xlUp).Row).Value
tmpI = Sheet1.Range("A2:E" & Sheet2.Range("A" & Rows.Count).End(xlUp).Row).Value
'--------------------
For i = 1 To UBound(tmpF, 1)    '------Cho i chay cac phan tu trong mang sheetF
m = m + 1   '-------------------Dong thoi tao phan tu mang kq
    dkF = tmpF(i, 1) & tmpF(i, 2) & tmpF(i, 3)  '--Tao chuoi dieu kien sheetF
    For k = 1 To UBound(tmpI, 1)    '----------Duyet qua cac phan tu cua sheet I
        dkbs = Format(Year(tmpI(k, 1)), "0000") & Format(Month(tmpI(k, 1)), "00") & Format(Day(tmpI(k, 1)), "00")   '-Dieu kien neu chuan dinh dang
        dkbs1 = Right(tmpI(k, 1), 4) & Left(tmpI(k, 1), 2) & Mid(tmpI(k, 1), 4, 2)  '-------Dieu kien neu khong chuan dinh dang
        dkI = dkbs & tmpI(k, 2) & tmpI(k, 3)    '----Tao dieu kien tham chieu ben sheet I voi dinh dang chuan
        dkI1 = dkbs1 & tmpI(k, 2) & tmpI(k, 3)  '----Tao dieu kien tham chieu ben sheet I voi dinh dang khong chuan
        If dkF = dkI Or dkF = dkI1 Then '--------so sanh dieu kien giua 2 sheet neu True then
            ArrKq(m, 1) = tmpI(k, 4)
            ArrKq(m, 2) = tmpI(k, 5)
            Exit For    '---------Thoat vong lap k
        End If
    Next k
Next i
Sheet2.Range("G2").Resize(UBound(ArrKq, 1), 2) = ArrKq  '---------Gan ket qua
MsgBox Timer() - Tm
End Sub
 
Sửa lần cuối bởi điều hành viên:

dieulinhneu96

Yêu THVBA
@dieulinhdieulinh
Mình tay ngang nên code rất thô, thời gian chạy rất rất lâu. Với dữ liệu 1000 dòng sheetF đã mất tầm 4s, mà nếu 2000 dòng thì là 15s =)). Bạn có thể tham khảo tạm. Tính đúng sai mình chưa test nhé :D

Mã:
Sub abc()
On Error Resume Next
Dim Tm As Double
Tm = Timer()
Dim tmpF, tmpI() '------------Khai bao bien
Dim ArrKq(1 To 65000, 1 To 2)
Dim i, k, m As Long
Dim dkF, dkI, dkI1 As String
Dim dkbs, dkbs1 As String
'--------------Xac dinh mang doi chieu
tmpF = Sheet2.Range("B2:F" & Sheet2.Range("B" & Rows.Count).End(xlUp).Row).Value
tmpI = Sheet1.Range("A2:E" & Sheet2.Range("A" & Rows.Count).End(xlUp).Row).Value
'--------------------
For i = 1 To UBound(tmpF, 1)    '------Cho i chay cac phan tu trong mang sheetF
m = m + 1   '-------------------Dong thoi tao phan tu mang kq
    dkF = tmpF(i, 1) & tmpF(i, 2) & tmpF(i, 3)  '--Tao chuoi dieu kien sheetF
    For k = 1 To UBound(tmpI, 1)    '----------Duyet qua cac phan tu cua sheet I
        dkbs = Format(Year(tmpI(k, 1)), "0000") & Format(Month(tmpI(k, 1)), "00") & Format(Day(tmpI(k, 1)), "00")   '-Dieu kien neu chuan dinh dang
        dkbs1 = Right(tmpI(k, 1), 4) & Left(tmpI(k, 1), 2) & Mid(tmpI(k, 1), 4, 2)  '-------Dieu kien neu khong chuan dinh dang
        dkI = dkbs & tmpI(k, 2) & tmpI(k, 3)    '----Tao dieu kien tham chieu ben sheet I voi dinh dang chuan
        dkI1 = dkbs1 & tmpI(k, 2) & tmpI(k, 3)  '----Tao dieu kien tham chieu ben sheet I voi dinh dang khong chuan
        If dkF = dkI Or dkF = dkI1 Then '--------so sanh dieu kien giua 2 sheet neu True then
            ArrKq(m, 1) = tmpI(k, 4)
            ArrKq(m, 2) = tmpI(k, 5)
            Exit For    '---------Thoat vong lap k
        End If
    Next k
Next i
Sheet2.Range("G2").Resize(UBound(ArrKq, 1), 2) = ArrKq  '---------Gan ket qua
MsgBox Timer() - Tm
End Sub
Cảm ơn bạn đã giúp đỡ ^^
Mình chạy thử thì "Not responding" bạn ạ :cry:
 
H

haokira

Guest
@dieulinhneu96 Đúng rồi, của mình cũng "Not responding" mà =))
Thế nên mình chỉ thử chạy 2000 dòng thôi.
Mình đoán dùng Dictionary thì nhanh hơn nhưng cái này mình lơ mơ không hiểu. Bạn đợi sự trợ giúp khác vậy
 
Sửa lần cuối bởi điều hành viên:

linhlbk

Yêu THVBA
@dieulinhneu96
Thử xem code này nhé, với dữ liệu lớn dùng dictionary sẽ là lựa chọn tốt.
Mã:
Sub compare()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim dict As Object, dict1 As Object

Dim ShI As Worksheet, ShF As Worksheet
Dim lri As Integer, lrf As Integer
Dim val As Variant
tim1 = Now

Set dict = CreateObject("Scripting.Dictionary")
Set dict1 = CreateObject("Scripting.Dictionary")

Set ShI = ThisWorkbook.Sheets("I")
Set ShF = ThisWorkbook.Sheets("F")
lri = ShI.Cells(Rows.Count, 1).End(xlUp).Row
lrf = ShF.Cells(Rows.Count, 1).End(xlUp).Row
For i = 3 To lri
    If Len(ShI.Cells(i, 3)) = 1 Then
        If Len(ShI.Cells(i, 4)) = 1 Then
            val = ShI.Cells(i, 2) & "0" & ShI.Cells(i, 3) & "0" & ShI.Cells(i, 4) & ShI.Cells(i, 5) & ShI.Cells(i, 6)
            dict.Add Key:=val, Item:=ShI.Cells(i, 7)
            dict1.Add Key:=val, Item:=ShI.Cells(i, 8)
        Else: val = ShI.Cells(i, 2) & "0" & ShI.Cells(i, 3) & ShI.Cells(i, 4) & ShI.Cells(i, 5) & ShI.Cells(i, 6)
            dict.Add Key:=val, Item:=ShI.Cells(i, 7)
            dict1.Add Key:=val, Item:=ShI.Cells(i, 8)
        End If
    Else:
        If Len(ShI.Cells(i, 4)) = 1 Then
            val = ShI.Cells(i, 2) & ShI.Cells(i, 3) & "0" & ShI.Cells(i, 4) & ShI.Cells(i, 5) & ShI.Cells(i, 6)
            dict.Add Key:=val, Item:=ShI.Cells(i, 7)
            dict1.Add Key:=val, Item:=ShI.Cells(i, 8)
        Else: val = ShI.Cells(i, 2) & ShI.Cells(i, 3) & ShI.Cells(i, 4) & ShI.Cells(i, 5) & ShI.Cells(i, 6)
            dict.Add Key:=val, Item:=ShI.Cells(i, 7)
            dict1.Add Key:=val, Item:=ShI.Cells(i, 8)
        End If
    End If
Next i

For j = 3 To lrf
    key_check = ShF.Cells(j, 3) & ShF.Cells(j, 4) & ShF.Cells(j, 5) & ShF.Cells(j, 6) & ShF.Cells(j, 7)
    If dict.exists(key_check) Then
        ShF.Cells(j, 10) = dict(key_check)
        ShF.Cells(j, 11) = dict1(key_check)
    End If
Next j
Set dict = Nothing
Set dict1 = Nothing
tim2 = Now
MsgBox Format(tim2 - tim1, "ss.ms")

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
 
Sửa lần cuối:

NhanSu

SMod
Thành viên BQT
Bạn thử code này sử dụng Dic (nhớ chọn Tools - Reference - Microsoft Scripting - Runtime). Với dữ liệu ít trên file mẫu thì dùng Dic khá nhanh. Tuy nhiên nếu dữ liệu của bạn nhiều và đã được sort thì Dic không nhanh bằng so sánh trực tiếp, giải thuật cũng đơn giản nên mình để các bạn làm thêm cho vui.
Mã:
Sub UsingDic()
    Dim Dic As New Dictionary
    Dim SheetIArr(), SheetFArr(), KQArr()
    Dim i&, k&, m&, n&, t
    Application.ScreenUpdating = False
    m = Sheets("I").Range("B1000000").End(xlUp).Row
    SheetIArr = Sheets("I").Range("B3:H" & m).Value
    n = Sheets("F").Range("C1000000").End(xlUp).Row
    SheetFArr = Sheets("F").Range("C3:G" & n).Value
    ReDim KQArr(1 To n - 2, 1 To 2)
    For i = 1 To m - 2
        t = DateSerial(SheetIArr(i, 1), SheetIArr(i, 2), SheetIArr(i, 3)) + _
            TimeSerial(SheetIArr(i, 4), SheetIArr(i, 5), 0)
        Dic.Item(t) = i
    Next
    For i = 1 To n - 2
        t = DateSerial(SheetFArr(i, 1), SheetFArr(i, 2), SheetFArr(i, 3)) + TimeSerial(SheetFArr(i, 4), SheetFArr(i, 5), 0)
        If Dic.Exists(t) Then
            k = Dic.Item(t)
            KQArr(i, 1) = SheetIArr(k, 6)
            KQArr(i, 2) = SheetIArr(k, 7)
        End If
    Next
    Sheets("F").Range("J3:K" & n) = KQArr
    Application.ScreenUpdating = True
End Sub
 
Top