Lại một lần nữa em làm phiền các thầy, cô , chú , anh , chị rồi
Lọc sang hết thì em có thể dùng for next lọc từng hàng sang được, nhưng cái khó thì như file (dữ liệu thực rất hay trùng như thế)
Thanks a lot
Private Sub CommandButton1_Click()
Dim r1 As Range, r2 As Range, i As Long, iR As Long, key As String, aR(), k As Long
Dim scr As Scripting.Dictionary
Set r1 = Sheet2.Range("E2").End(xlDown).Offset(1)
Set r2 = Sheet1.Range(Sheet1.Range("D11"), Sheet1.Range("D11").End(xlDown)).Resize(, 9)
iR = r2.Rows.Count
ReDim aR(1 To iR, 1 To 2)
k = 0
Set scr = New Scripting.Dictionary
For i = 1 To iR
key = r2(i, 1) & "<0|0>" & r2(i, 5)
If Not scr.Exists(key) Then
scr.Add key, r2(i, 9)
k = k + 1
aR(k, 1) = i
Else
scr.Item(key) = scr.Item(key) + r2(i, 9)
End If
aR(k, 2) = scr.Item(key)
Next
Set r1 = r1.Resize(k, 5)
For i = 1 To k
r1(i, 1) = r2(aR(i, 1), 1)
r1(i, 3) = r2(aR(i, 1), 5)
r1(i, 4) = r2(aR(i, 1), 6)
r1(i, 5) = aR(i, 2)
Next
'r2.ClearContents - tùy chọn xóa nội dung sau khi cập nhật'
Set r1 = Nothing
Set r2 = Nothing
Set scr = Nothing
Erase aR
End SubLấy cái đầu tiên ạ, thường thì nếu có thì hay trùng nhau từ đầu đến cuối. nên ko quan tâm cái này lắm.
Xin lỗi vì chưa chuyển sang chế độ tương thích với người dùng, bạn sử lại như dướiLấy cái đầu tiên ạ, thường thì nếu có thì hay trùng nhau từ đầu đến cuối. nên ko quan tâm cái này lắm.
Private Sub CommandButton1_Click()
Dim r1 As Range, r2 As Range, i As Long, iR As Long, key As String, aR(), k As Long
Dim scr As Object 'As Scripting.Dictionary'
Set r1 = Sheet2.Range("E2").End(xlDown).Offset(1)
Set r2 = Sheet1.Range(Sheet1.Range("D11"), Sheet1.Range("D11").End(xlDown)).Resize(, 9)
iR = r2.Rows.Count
ReDim aR(1 To iR, 1 To 2)
k = 0
Set scr = CreateObject("Scripting.Dictionary") 'New Scripting.Dictionary'
For i = 1 To iR
key = r2(i, 1) & "<0|0>" & r2(i, 5)
If Not scr.Exists(key) Then
scr.Add key, r2(i, 9)
k = k + 1
aR(k, 1) = i
Else
scr.Item(key) = scr.Item(key) + r2(i, 9)
End If
aR(k, 2) = scr.Item(key)
Next
Set r1 = r1.Resize(k, 5)
For i = 1 To k
r1(i, 1) = r2(aR(i, 1), 1)
r1(i, 3) = r2(aR(i, 1), 5)
r1(i, 4) = r2(aR(i, 1), 6)
r1(i, 5) = aR(i, 2)
Next
'r2.ClearContents - tùy chọn xóa dữ liệu sau khi cập nhật'
Set r1 = Nothing
Set r2 = Nothing
Set scr = Nothing
Erase aR
End SubE thử rồi trên excel 2003. lỗi như post 5
Chỉ là chưa bẫy lỗi thôi mà! Ngoài ra, để đảm bảo tính chính xác khi các tài khoản nhập không theo thứ tự (khi có trùng nhau), tôi thay đổi thuật toán lại như sau:
Private Sub CommandButton1_Click()
Dim r1 As Range, r2 As Range, i As Long, j As Long, iR As Long, key As String, aR(), k As Long
Set r1 = Sheet2.Range("E10000").End(xlUp).Offset(1)
On Error Resume Next
Set r2 = Sheet1.Range(Sheet1.Range("D11"), Sheet1.Range("D11").End(xlDown)).Resize(, 9)
On Error GoTo 0
If r2 Is Nothing Then Exit Sub
iR = r2.Rows.Count
ReDim aR(1 To iR, 1 To 9)
aR = r2
k = 0
For i = 1 To iR - 1
If aR(i, 1) <> "" Then
key = aR(i, 1) & "<0|0>" & aR(i, 5)
For j = i + 1 To iR
If aR(j, 1) <> "" Then
If aR(j, 1) & "<0|0>" & aR(j, 5) = key Then
aR(i, 9) = aR(i, 9) + aR(j, 9)
aR(j, 1) = ""
End If
End If
Next
End If
Next
Set r1 = r1.Resize(iR, 5)
For i = 1 To iR
If aR(i, 1) <> "" Then
k = k + 1
r1(k, 1) = aR(i, 1)
r1(k, 3) = aR(i, 5)
r1(k, 4) = aR(i, 6)
r1(k, 5) = aR(i, 9)
End If
Next
'r2.ClearContents
Set r1 = Nothing
Set r2 = Nothing
Erase aR
End Sub
