Xin code khớp phách điểm thi (2 người xem)

[Tran Mui]

Nhờ GPE giúp tôi đoạn Code để khớp điểm thi theo mã phách
yêu cầu cụ thể file đính kèm
Xin cảm ơn

 

[ndu96081631]

Nhờ GPE giúp tôi đoạn Code để khớp điểm thi theo mã phách
yêu cầu cụ thể file đính kèm
Xin cảm ơn

Bạn VLOOKUP 1 phát là ra toàn bộ, cần quái gì code kiết cho mệt

 

[Tran Mui]

Bạn Ndu ơi mình muốn từ ví dụ này còn khớp cho nhiều môn

 

[ndu96081631]

Bạn Ndu ơi mình muốn từ ví dụ này còn khớp cho nhiều môn

Trước tôi có viết hàm Filter2DArray, giờ đưa vào áp dụng thôi ---> Xem file

 

[ThuNghi]

Bạn Ndu ơi mình muốn từ ví dụ này còn khớp cho nhiều môn

Sub KhopPhach()
With Application
  .ScreenUpdating = False: .Calculation = xlCalculationManual
End With
Dim endR&, i&, j&
Dim sPhach$, sTmp$
Dim Arr(), ArrPh()
With Sheets("THop")
  endR = .Cells(65000, 7).End(xlUp).Row
  ArrPh = .Range("G7:I" & endR).Value
End With
With Sheets("In_ketqua")
  endR = .Cells(65000, 7).End(xlUp).Row
  Arr = .Range("B7:I" & endR).Value
End With
For i = 1 To UBound(Arr)
  sPhach = CStr(Arr(i, 6) & Arr(i, 7))
  For j = 1 To UBound(ArrPh)
    sTmp = CStr(ArrPh(j, 1) & ArrPh(j, 2))
    If Len(sTmp) > 0 Then
      If sPhach = sTmp Then
        Arr(i, 8) = ArrPh(j, 3)
        GoTo Exit_For
      End If
    End If
  Next j
Exit_For:
Next i
With Sheets("In_ketqua")
  .[B7].Resize(UBound(Arr), 8) = Arr
End With
Erase Arr(), ArrPh()
With Application
  .ScreenUpdating = True: .Calculation = xlCalculationAutomatic
End With
End Sub

Nếu thích code thì có code.

 

[Ếch Xanh]

Lần đầu tiên tôi mới thấy ID mà để trên 2 cột!
Với File của bạn, tôi thêm 1 cột tại sheet THop, cột này sẽ nối chuỗi giữa 2 cột Mã Phách với nhau tạo thành 1 ID mới. Tương tự với sheet còn lại.
Sau đó tôi chỉ việc dùng hàm VLOOKUP để dò tìm số điểm, tôi thấy như vậy sẽ nhanh hơn và hiệu quả hơn. Dĩ nhiên tôi cũng có thể viết Code cho bạn:

Sub KhopPhach()
  On Error Resume Next
  Dim TableArray As Range, LookupValue As Range, Cls As Range
  Set LookupValue = Range(Sheet31.[I7], Sheet31.[I65536].End(xlUp))
  Set TableArray = Range(Sheet29.[I7], Sheet29.[I65536].End(xlUp))
  LookupValue.Offset(, 1).ClearContents
  For Each Cls In LookupValue
    If Cls <> "" Then Cls.Offset(, 1).Value = WorksheetFunction.VLookup(Cls, TableArray.Resize(, 2), 2, 0)
  Next
End Sub

Như vậy code sẽ ngắn gọn hơn, tốc độ xử lý sẽ nhanh hơn. Bạn có thể ẩn cột ID mới (hoặc 2 cái cột mã phách của bạn).

 

[ndu96081631]

Như vậy code sẽ ngắn gọn hơn, tốc độ xử lý sẽ nhanh hơn. Bạn có thể ẩn cột ID mới (hoặc 2 cái cột mã phách của bạn).

Code gọn hơn thì đúng rồi (ngay từ đầu tôi đã đề xuất VLOOKUP vì nó gọn)... chứ còn nhanh hơn thì... không thể nào
Ẹc... Ẹc...

 

[Ếch Xanh]

Code gọn hơn thì đúng rồi (ngay từ đầu tôi đã đề xuất VLOOKUP vì nó gọn)... chứ còn nhanh hơn thì... không thể nào
Ẹc... Ẹc...

Em đã thử trên bài của Thầy, dám chắc với File này, tốc độ nhanh hơn của Thầy đó! (Còn nếu nhiều hàng hơn, thì chưa thử)

 

[bebo021999]

Em đã thử trên bài của Thầy, dám chắc với File này, tốc độ nhanh hơn của Thầy đó!

Hic, sao "xoay" phải nhanh hơn sao "liệt" chứ!

 

[ndu96081631]

Em đã thử trên bài của Thầy, dám chắc với File này, tốc độ nhanh hơn của Thầy đó! (Còn nếu nhiều hàng hơn, thì chưa thử)

Cái file của tôi là vì dùng qua trung gian hàm Filter2DArray, có những chổ quá thừa đối với yêu cầu bài này (mà tôi thì lười viết lại đối với những code có cùng thuật toán)
Thử với code của ThuNghi và thử cở 20,000 dòng xem (Code của ThuNghi viết vừa đủ cho bài này)

 

[concogia]

Lần đầu tiên tôi mới thấy ID mà để trên 2 cột!
Với File của bạn, tôi thêm 1 cột tại sheet THop, cột này sẽ nối chuỗi giữa 2 cột Mã Phách với nhau tạo thành 1 ID mới. Tương tự với sheet còn lại.
Sau đó tôi chỉ việc dùng hàm VLOOKUP để dò tìm số điểm, tôi thấy như vậy sẽ nhanh hơn và hiệu quả hơn. Dĩ nhiên tôi cũng có thể viết Code cho bạn:

Sub KhopPhach()
On Error Resume Next
Dim TableArray As Range, LookupValue As Range, Cls As Range
Set LookupValue = Range(Sheet31.[I7], Sheet31.[I65536].End(xlUp))
Set TableArray = Range(Sheet29.[I7], Sheet29.[I65536].End(xlUp))
LookupValue.Offset(, 1).ClearContents
For Each Cls In LookupValue
If Cls <> "" Then Cls.Offset(, 1).Value = WorksheetFunction.VLookup(Cls, TableArray.Resize(, 2), 2, 0)
Next
End Sub

Như vậy code sẽ ngắn gọn hơn, tốc độ xử lý sẽ nhanh hơn. Bạn có thể ẩn cột ID mới (hoặc 2 cái cột mã phách của bạn).

Híc, "Cò" đua tốc độ với "Ếch xanh" nào

Public Sub Phach()
    Dim Kq, NhanKq, d, I, K, Tam(), Mg(), Ws, M, N, Tg As Double
    Set Ws = Sheets("In_ketqua"): Tg = Timer
    Set d = CreateObject("scripting.dictionary")
    NhanKq = Ws.Range(Ws.[g7], Ws.[g1000].End(xlUp)).Resize(, 2).Value
    Kq = Range([g7], [g10000].End(xlUp)).Resize(, 3).Value
        ReDim Tam(1 To UBound(Kq), 1 To 1)
            For I = 1 To UBound(Kq)
                If Kq(I, 1) <> vbNullString Then
                    If Not d.exists(Kq(I, 1) & Kq(I, 2)) Then
                        K = K + 1
                        d.Add Kq(I, 1) & Kq(I, 2), K
                        Tam(K, 1) = Kq(I, 3)
                    End If
                End If
            Next I
                ReDim Mg(1 To UBound(NhanKq), 1 To 1)
                    For I = 1 To UBound(NhanKq)
                        If d.exists(NhanKq(I, 1) & NhanKq(I, 2)) Then
                            M = d.Item(NhanKq(I, 1) & NhanKq(I, 2))
                            Mg(I, 1) = Tam(M, 1)
                        End If
                    Next I
   Ws.[i7:i1000].ClearContents
   Ws.[i7].Resize(UBound(NhanKq)) = Mg
   MsgBox "Tg: " & Timer - Tg
End Sub

 

[ThuNghi]

Híc, "Cò" đua tốc độ với "Ếch xanh" nào

Public Sub Phach()
    Dim Kq, NhanKq, d, I, K, Tam(), Mg(), Ws, M, N, Tg As Double
    Set Ws = Sheets("In_ketqua"): Tg = Timer
    Set d = CreateObject("scripting.dictionary")
    NhanKq = Ws.Range(Ws.[g7], Ws.[g1000].End(xlUp)).Resize(, 2).Value
...
ReDim Mg(1 To UBound(NhanKq), 1 To 1)
                    For I = 1 To UBound(NhanKq)
                        If d.exists(NhanKq(I, 1) & NhanKq(I, 2)) Then
                            M = d.Item(NhanKq(I, 1) & NhanKq(I, 2))
                            Mg(I, 1) = Tam(M, 1)
                        End If
                    Next I
   Ws.[i7:i1000].ClearContents
   Ws.[i7].Resize(UBound(NhanKq)) = Mg
   MsgBox "Tg: " & Timer - Tg
End Sub

Dùng Dic thì chắc sẽ nhanh hơn rồi.
Nhưng code của Bác là tạo dư ra 1 arr Mg nên phải redim không cần thiết.
Cám ơn Bác nhiều.

 

[TrungChinhs]

Nhờ GPE giúp tôi đoạn Code để khớp điểm thi theo mã phách
yêu cầu cụ thể file đính kèm
Xin cảm ơn

Xin "chầu rìa 1 nước" góp vui
Tôi thấy tại File THop bạn đã chia mã phách theo nhóm (để cách dòng trống) và ở cả 2 sheet trong mỗi nhóm phách đều được gieo thứ tự từ 1 đến hết nên tôi lợi dụng đặc điểm này để viết code khớp phách như sau:

Sub Khop_Phach()
    Application.ScreenUpdating = False
    Tg = Timer
    Sheets("In_ketqua").[i7:i10000].Clear
    With Sheets("THop").[g7:g10000].SpecialCells(2)
        For I = 1 To .Areas.Count
            .Areas(I).Offset(, 2).Copy Sheets("In_ketqua").Cells.Find(.Areas(I))(1, 3)
        Next
    End With
    MsgBox "End time: " & Timer - Tg
End Sub

 

[kieuhuy_bmt]

Gửi bác concogia_nhờ tiếp tục giúp

Híc, "Cò" đua tốc độ với "Ếch xanh" nào

Public Sub Phach()
Dim Kq, NhanKq, d, I, K, Tam(), Mg(), Ws, M, N, Tg As Double
Set Ws = Sheets("In_ketqua"): Tg = Timer
Set d = CreateObject("scripting.dictionary")
NhanKq = Ws.Range(Ws.[g7], Ws.[g1000].End(xlUp)).Resize(, 2).Value
Kq = Range([g7], [g10000].End(xlUp)).Resize(, 3).Value
ReDim Tam(1 To UBound(Kq), 1 To 1)
For I = 1 To UBound(Kq)
If Kq(I, 1) <> vbNullString Then
If Not d.exists(Kq(I, 1) & Kq(I, 2)) Then
K = K + 1
d.Add Kq(I, 1) & Kq(I, 2), K
Tam(K, 1) = Kq(I, 3)
End If
End If
Next I
ReDim Mg(1 To UBound(NhanKq), 1 To 1)
For I = 1 To UBound(NhanKq)
If d.exists(NhanKq(I, 1) & NhanKq(I, 2)) Then
M = d.Item(NhanKq(I, 1) & NhanKq(I, 2))
Mg(I, 1) = Tam(M, 1)
End If
Next I
Ws.[i7:i1000].ClearContents
Ws.[i7].Resize(UBound(NhanKq)) = Mg
MsgBox "Tg: " & Timer - Tg
End Sub

Tôi có nhờ bác sửa cáo code tổng hợp điện tích và đc bác sửa. Song nay muốn nhờ bác hoàn thiện thêm. Vậy nhờ bác xem http://www.giaiphapexcel.com/forum/attachment.php?