Bạn dùng mảng là nhanh rồi, tuy nhiên trong code: khi dã lấy được dữ liệu , vòng lặp J vẫn chạy tiếp mà không thoát.
Bạn thử.
Sub laydulieu()
Dim arr, i As Long, lr As Long, dic As Object, dk As String, k As Integer
Set dic = CreateObject("scripting.dictionary")
With Sheet7
lr = .Range("B" & Rows.Count).End(xlUp).Row
arr = .Range("B6:F" & lr).Value
For i = 1 To UBound(arr)
dk = arr(i, 1)
If Not dic.exists(dk) Then
dic.Add dk, Array(arr(i, 3), arr(i, 5))
End If
Next i
End With
With Sheet8
lr = .Range("D" & Rows.Count).End(xlUp).Row
arr = .Range("I7:X" & lr).Value
For k = 1 To UBound(arr, 2) Step 4
For i = 1 To UBound(arr)
dk = arr(i, k)
If dic.exists(dk) Then
arr(i, k + 2) = dic.Item(dk)(0)
arr(i, k + 3) = dic.Item(dk)(1)
Else
arr(i, k + 2) = Empty
arr(i, k + 3) = Empty
End If
Next i
Next k
.Range("I7:X" & lr).Value = arr
End With
End SubCảm ơn snow25. Mình test thấy code chạy rất nhanh nhưng chạy khoảng 300 HS đầu mỗi môn điểm nạp vào đúng còn lại những HS sau điểm không đúng. Bạn xem lại giúp với.
Mình chưa nghiên cứu Dic nên không hiểu về nó đành viết kiểu này. Mình đã thử dùng 1 vòng lặp ngoài lấy mã bên KQ, một vòng lặp để lấy mã bên tổng hợp để so sánh. Mỗi lần lặp so sánh cả 4 môn luôn nhưng tốc độ chạy vẫn rất chậm.
Bạn thử nhé.Mình dùng Dictionary bạn tham khảo.Mình đã sửa chỗ điều kiện để kiểm tra.
Sub laydulieu()
Dim arr, i As Long, lr As Long, dic As Object, dk As String, k As Integer
Set dic = CreateObject("scripting.dictionary")
With Sheet7
lr = .Range("B" & Rows.Count).End(xlUp).Row
arr = .Range("B6:F" & lr).Value
For i = 1 To UBound(arr)
dk = arr(i, 1) & "#" & arr(i, 2)
If Not dic.exists(dk) Then
dic.Add dk, Array(arr(i, 3), arr(i, 5))
End If
Next i
End With
With Sheet8
lr = .Range("D" & Rows.Count).End(xlUp).Row
arr = .Range("I7:X" & lr).Value
For k = 1 To UBound(arr, 2) Step 4
For i = 1 To UBound(arr)
dk = arr(i, k) & "#" & arr(i, k + 1)
If dic.exists(dk) Then
arr(i, k + 2) = dic.Item(dk)(0)
arr(i, k + 3) = dic.Item(dk)(1)
Else
arr(i, k + 2) = Empty
arr(i, k + 3) = Empty
End If
Next i
Next k
.Range("I7:X" & lr).Value = arr
End With
End SubMình mới kiểm tra thấy đã khớp dữ liệu. Mình sẽ kiểm tra tiếp, có gì mình sẽ nhờ bạn giúp đỡ tiếp. Cảm ơn bạn nhiều.
Bạn xem kết quả có đúng ý không? Thử không dùng vòng lặp xem có chạy nhanh hơn không?
Bạn làm ngược vấn đề rồi. Mình cần lấy từ sheet KQ chấm vào sheet Điểm. Bạn sủa lại được không?
Thử code siêu tốc và siêu liều
Sub UongThuocLieu()
Dim sArr(), j&, fRow&, fCol&
Const sRow& = 4200
fRow = 6: fCol = 11
Application.ScreenUpdating = False
For j = 1 To 4
Sheet8.Cells(7, fCol).Resize(sRow) = Sheet7.Cells(fRow, 4).Resize(sRow).Value2
Sheet8.Cells(7, fCol + 1).Resize(sRow) = Sheet7.Cells(fRow, 6).Resize(sRow).Value2
fRow = fRow + sRow
fCol = fCol + 4
Next j
Application.ScreenUpdating = True
End SubCảm ơn HieuCD code rất gọn mà chạy nhanh. Không dùng mảng, Dic sao chạy nhanh thế nhỉ. Trong code không có lệnh kiểm tra so khớp mã bài, mã phòng liệu có nhầm điểm của HS này sang HS khác không. Mình sẽ test kỹ.
Nhầm là chắc, khi dữ liệu kiểu khác...
sRow là hằng. Resize liên tục code trông không rõ. Lấy trọn 1 lần vào range rồi dùng Offset dễ kiểm soát hơn.
Cảm ơn bạn.
