Cảm ơn anh
Trước đây em vẫn làm công thức hoặc dùng filter nhưng mỗi lần chèn thêm dòng thì lại phải chạy lại công thức từ đầu. Nên em muốn xin code để đánh dấu cột G
Public Sub DanhDauX()
Dim i As Long
Dim lr As Long
Dim sArr, dArr
lr = Range("A" & Rows.Count).End(xlUp).Row
sArr = Range("A2:D" & lr).Value
lr = UBound(sArr, 1)
ReDim dArr(1 To lr, 1 To 1)
For i = 1 To lr
If sArr(i, 1) <> sArr(i, 3) Or sArr(i, 2) <> sArr(i, 4) Then dArr(i, 1) = "X"
Next
Range("G2").Resize(lr, 1) = dArr
End Subrecord macro + xào xáo dược code này
Option Explicit
Sub Macro1()
Dim rws
With Sheet1
rws = .Range("A1000000").End(xlUp).Row
Range("A1", "G" & rws).AutoFilter Field:=6, Criteria1:="FALSE"
Range("G4:G10943") = "x"
Range("A1", "G" & rws).AutoFilter Field:=6
Range("A1", "G" & rws).AutoFilter Field:=5, Criteria1:="FALSE"
Range("G4:G10943") = "x"
Range("A1", "G" & rws).AutoFilter
End With
End SubCảm ơn bạn đã giúp đỡ, chúc bạn cuối tuần vui vẻ nhé
Thử một cách khác:
Sub DanhDau()
Dim row As Integer
Dim DongCuoi As Long
DongCuoi = Sheet1.Range("B" & Rows.Count).End(xlUp).row
For row = 2 To DongCuoi
If StrComp("TRUE", Cells(row, 5).Value, vbTextCompare) Or _
StrComp("TRUE", Cells(row, 6).Value, vbTextCompare) Then
Cells(row, 7).Value = "X"
End If
Next row
End SubEm cảm ơn anh be09 đã giúp đỡ. Chúc anh ngày vui
Anh ơi! em áp dụng code của anh, nhưng khi tăng số lượng cột so khớp lên thì code bị lỗi
https://www.mediafire.com/file/45qd15y5vg60g99/ProgreesBar.rar/fileMáy tính xử lý các con số gần đúng nên so sánh "=" hoặc "<>" có lúc loạn cào cào
Thêm một lần Cảm ơn anh. Nhưng mà cái này thú vị thật. Rõ ràng trên bảng tính , Excel xác nhận là 124409.36=124409.36 = TRUE nhưng khi đưa vào VBA lại False
Sửa code bài 9 lại 1 tí:
Sub DanhDau()
Dim row As Integer
Dim DongCuoi As Long
DongCuoi = Sheet1.Range("B" & Rows.Count).End(xlUp).row
For row = 2 To DongCuoi
If StrComp("TRUE", Cells(row, 7).Value, vbTextCompare) Or _
StrComp("TRUE", Cells(row, 8).Value, vbTextCompare) Or _
StrComp("TRUE", Cells(row, 9).Value, vbTextCompare) Then
Cells(row, 10).Value = "X"
End If
Next row
End SubCảm ơn anh. Hôm nay gặp mới biết. Cái này đúng là ngoài tầm hiểu biết của em, rõ ràng trên bảng tính em đã xem đến hàng thập phân thứ 20 mà hai số vẫn cứ là 124409.36000000000000000000000000.
Vâng code này của anh ra đúng ạ
Sai số nầy nằm trong code, còn trên bảng tính có lẽ ngài Bil đã loại lỗi nầy
Sub Button1_Click()
Dim i As Long
Dim lr As Long
Dim sArr, dArr
lr = Range("A" & Rows.Count).End(xlUp).Row
sArr = Range("A2:F" & lr).Value
lr = UBound(sArr, 1)
ReDim dArr(1 To lr, 1 To 1)
For i = 1 To lr
'****
If i = 1051 Then
e = sArr(i, 3) - sArr(i, 6)
End If
'****
If sArr(i, 1) <> sArr(i, 4) Or sArr(i, 2) <> sArr(i, 5) Or sArr(i, 3) <> sArr(i, 6) Then dArr(i, 1) = "x"
Next
Range("J2").Resize(lr, 1) = dArr
MsgBox (lr)
End SubCảm ơn anh. Em vẫn đang làm so khớp cho phần còn lại của cái bảng tính này. Khi nào xong em sẽ nghiên cứu kiến thức mới của anh
Số trên máy tính chỉ chính xác đến chữ số thứ 15. Hàng thập phân thứ 20 chỉ bằng thừa.
Sao không đưa bài toàn từ thuở sơ khai (tức là đưa dữ liệu thô ban đầu) rồi xử lý để có kết quả cuối cùng là gì?
Cảm ơn anh befaint đã góp ý. Đúng như anh nói, đây không phải là dữ liệu thô ban đầu, nhưng mà nó cũng gần như thô rồi anh à; 6 cột của sheet Database được filter từ số dư đầu kỳ của bảng dữ liệu tồn kho năm 2017 và 2018. Và trước khi đưa vào file này em chỉ sort A-Z, trim (mã) thôi.
Vâng! đánh dấu x chỉ là phương pháp em làm thủ công để ra sheet Kết quả. Em xin gửi lại file
Anh ơi! cái này là kết quả cuối cùng mà em mong muốn của việc đối chiếu rồi anh à! Từ các chênh lệch này em sẽ tiến hành điều chỉnh dữ liệu tồn kho
Vâng đây chính là bản chất của bài toán. Tại vì từ đầu em chưa biết cái kết quả cuối cùng nó hình thù ra sao , nên làm thủ công để ra kết quả trước, rồi sau đó gửi cái kết quả lên lên GPE mong các anh cho phương án.
Chôm Code của bạn @befaint, thêm vài lệnh
Sub SortedListFilter()
Dim oSList As Object, sKey As String
Dim sArr1(), sArr2(), Result(), S
Dim i As Long, sRow As Long, n As Long, j As Long
Set oSList = CreateObject("System.Collections.SortedList")
With Sheets("database")
sArr1 = .Range("A2:C" & .Range("A" & Rows.Count).End(xlUp).Row).Value
For i = 1 To UBound(sArr1)
sKey = Application.Trim(sArr1(i, 1))
If sKey <> "" Then
If oSList.ContainsKey(sKey) = False Then oSList.Add sKey, Array(i, 0)
End If
Next i
sArr2 = .Range("D2:F" & .Range("D" & Rows.Count).End(xlUp).Row).Value
For i = 1 To UBound(sArr2)
sKey = Application.Trim(sArr2(i, 1))
If sKey <> "" Then
If oSList.ContainsKey(sKey) = False Then
oSList.Add sKey, Array(0, i)
Else
oSList.Item(sKey) = Array(oSList.Item(sKey)(0), i)
End If
End If
Next i
End With
n = oSList.Count - 1
ReDim Result(0 To n, 1 To 6)
For i = 0 To n
S = oSList.GetByIndex(i)
If S(0) > 0 Then
For j = 1 To 3
Result(i, j) = sArr1(S(0), j)
Next j
End If
If S(1) > 0 Then
For j = 1 To 3
Result(i, j + 3) = sArr2(S(1), j)
Next j
End If
Next i
With Sheets("KQ")
i = .Range("A" & Rows.Count).End(xlUp).Row
j = .Range("D" & Rows.Count).End(xlUp).Row
If i < j Then i = j
If i > 1 Then .Range("A2:F" & i).Clear
.Range("A2").Resize(n + 1, 1).NumberFormat = "@"
.Range("D2").Resize(n + 1, 1).NumberFormat = "@"
.Range("A2").Resize(n + 1, 6) = Result
End With
End SubSub main()
Dim i As Integer
Dim j As Integer
Dim rend As Integer
Dim rend2 As Integer
Dim darr 'all-du lieu tu cot A ->F
Dim kqarr 'Du lieu de ghi ra sheet KQ
Dim allarr 'Dieu lieu ma nxt all tren cot A,D
Dim cota_arr 'du lieu cot A->C
Dim cotd_arr 'du lieu cot D->F
Dim outs As String 'ghi lai toan bo ma nxt tren cot A va D
Dim sfind As String ' ma nxt
Dim cnt As Integer
Dim cnt1 As Integer 'cot A
Dim cnt2 As Integer 'cot D
Dim arrkq
'Xac dinh dong cuoi cua du lieu
rend = ThisWorkbook.Sheets("DATA").Range("A" & Rows.Count).End(xlUp).row
rend2 = ThisWorkbook.Sheets("DATA").Range("D" & Rows.Count).End(xlUp).row
If rend < rend2 Then rend = rend2
If rend < 2 Then
MsgBox "Have not data. Please reconfirm"
Exit Sub
End If
ReDim kqarr(1 To 1, 1 To 6) 'Du lieu de ghi ra sheet KQ
darr = ThisWorkbook.Sheets("DATA").Range("A2:F" & rend).Value
'Xoa sach du lieu cot G truoc khi lam viec
ThisWorkbook.Sheets("DATA").Range("G2:J" & rend).ClearContents
ReDim allarr(1 To 1) 'Reset mang
ReDim cota_arr(1 To 3, 1 To 1) 'Reset mang
ReDim cotd_arr(1 To 3, 1 To 1) 'Reset mang
ReDim kqarr(1 To 10, 1 To 1)
' Call khoitaouserform
outs = ";" 'Chua co data gi
cnt = 0
cnt1 = 0
cnt2 = 0
For i = LBound(darr, 1) To UBound(darr, 1) Step 1
'neu ma don hang A khong phai la "" thi nap vao outs
sfind = Trim(CStr(darr(i, 1))) 'Loai bo khoang trang dau va cuoi
'co the khong can thiet neu nhu data duoc nap vao database da duoc xu ly khoang trang dau cuoi
If sfind <> "" Then
cnt1 = cnt1 + 1
ReDim Preserve cota_arr(1 To 3, 1 To cnt1)
cota_arr(1, cnt1) = Trim(CStr(darr(i, 1)))
cota_arr(2, cnt1) = Val(CStr(darr(i, 2)))
cota_arr(3, cnt1) = Val(CStr(darr(i, 3)))
sfind = sfind & ";"
If InStr(1, outs, sfind) = 0 Then
outs = outs & sfind
cnt = cnt + 1
ReDim Preserve allarr(1 To cnt)
allarr(cnt) = Trim(CStr(darr(i, 1)))
ReDim Preserve kqarr(1 To 10, 1 To cnt)
kqarr(1, cnt) = Trim(CStr(darr(i, 1)))
kqarr(2, cnt) = cota_arr(2, cnt1)
kqarr(3, cnt) = cota_arr(3, cnt1)
End If
End If
'neu ma don hang D khong phai la "" thi nap vao outs
sfind = Trim(CStr(darr(i, 4))) 'Loai bo khoang trang dau va cuoi
'co the khong can thiet neu nhu data duoc nap vao database da duoc xu ly khoang trang dau cuoi
If sfind <> "" Then
cnt2 = cnt2 + 1
ReDim Preserve cotd_arr(1 To 3, 1 To cnt2)
cotd_arr(1, cnt2) = Trim(CStr(darr(i, 4)))
cotd_arr(2, cnt2) = Val(CStr(darr(i, 5)))
cotd_arr(3, cnt2) = Val(CStr(darr(i, 6)))
sfind = sfind & ";"
If InStr(1, outs, sfind) = 0 Then
outs = outs & sfind
cnt = cnt + 1
ReDim Preserve allarr(1 To cnt)
allarr(cnt) = Trim(CStr(darr(i, 4)))
ReDim Preserve kqarr(1 To 10, 1 To cnt)
kqarr(4, cnt) = Trim(CStr(darr(i, 4)))
kqarr(5, cnt) = cotd_arr(2, cnt2)
kqarr(6, cnt) = cotd_arr(3, cnt2)
End If
End If
Next i
For i = 1 To cnt Step 1
'Cot A co ma nxt nhung cot D chua co thi tim kiem
If CStr(kqarr(4, i)) = "" And CStr(kqarr(1, i)) <> "" Then
j = findvitri(CStr(kqarr(1, i)), cotd_arr)
If j > 0 Then
kqarr(4, i) = cotd_arr(1, j)
kqarr(5, i) = cotd_arr(2, j)
kqarr(6, i) = cotd_arr(3, j)
End If
End If
'Cot D co ma nxt nhung cot A chua co thi tim kiem
If CStr(kqarr(4, i)) <> "" And CStr(kqarr(1, i)) = "" Then
j = findvitri(CStr(kqarr(4, i)), cota_arr)
If j > 0 Then
kqarr(1, i) = cota_arr(1, j)
kqarr(2, i) = cota_arr(2, j)
kqarr(3, i) = cota_arr(3, j)
End If
End If
'So sanh ma nxt
If CStr(kqarr(4, i)) <> CStr(kqarr(1, i)) Then
kqarr(7, i) = "FALSE"
kqarr(10, i) = "X"
Else
kqarr(7, i) = "TRUE"
End If
'so sanh so luong
If (Val(CStr(kqarr(5, i))) - Val(CStr(kqarr(2, i)))) <> 0 Then
kqarr(8, i) = "FALSE"
kqarr(10, i) = "X"
Else
kqarr(8, i) = "TRUE"
End If
'So sanh tien
If (Val(CStr(kqarr(6, i))) - Val(CStr(kqarr(3, i)))) <> 0 Then
kqarr(9, i) = "FALSE"
kqarr(10, i) = "X"
Else
kqarr(9, i) = "TRUE"
End If
Next i
arrkq = daochieumang(kqarr)
ThisWorkbook.Sheets("KQ").Range("A2").Resize(cnt, 10) = arrkq
End Sub
Function findvitri(ByVal s As String, ByVal farr As Variant) As Integer
Dim k As Integer
findvitri = 0
For k = LBound(farr, 2) To UBound(farr, 2) Step 1
If CStr(farr(1, k)) = s Then
findvitri = k
Exit Function
End If
Next k
End Function
Function daochieumang(ByVal farr As Variant) As Variant
Dim arr
Dim ro1 As Integer
Dim co1 As Integer
Dim ro2 As Integer
Dim co2 As Integer
Dim i1 As Integer
Dim j1 As Integer
ro1 = LBound(farr, 1)
ro2 = UBound(farr, 1)
co1 = LBound(farr, 2)
co2 = UBound(farr, 2)
ReDim arr(co1 To co2, ro1 To ro2)
For i1 = ro1 To ro2 Step 1
For j1 = co1 To co2 Step 1
arr(j1, i1) = farr(i1, j1)
Next j1
Next i1
daochieumang = arr
End FunctionEm chỉ có thể nói là Tuyệt vời quá anh ơi! Cảm ơn các anh rất nhiều.
Cảm ơn bạn đã nhiệt tình giúp đỡ. Mình sẽ chú ý đến kênh của bạn hơn. Hy vọng sẽ học hỏi thêm kiến thức về VBA.
Nếu dữ liệu đã Sort và loại khoảng trắng, không cần dùng SortList, code gọn và tốc độ nhanh hơn nhiều
Sub SoSanh()
Dim sArr1(), sArr2(), Res()
Dim k As Long, sRow As Long, n2 As Long
Dim i As Long, j As Long, i2 As Long, j2 As Long
With Sheets("database")
If .Range("A2").Value <= .Range("A2").Value Then
sArr1 = .Range("A2:C" & .Range("A" & Rows.Count).End(xlUp).Row).Value
sArr2 = .Range("D2:F" & .Range("D" & Rows.Count).End(xlUp).Row).Value
j = 1: j2 = 4
Else
sArr2 = .Range("A2:C" & .Range("A" & Rows.Count).End(xlUp).Row).Value
sArr1 = .Range("D2:F" & .Range("D" & Rows.Count).End(xlUp).Row).Value
j = 4: j2 = 1
End If
End With
sRow = UBound(sArr1)
ReDim Res(1 To sRow + UBound(sArr2), 1 To 6)
n2 = 1
For i = 1 To sRow
If i < sRow Then tmp = sArr1(i + 1, 1) Else tmp = "zzz"
k = k + 1
Res(k, j) = sArr1(i, 1)
Res(k, j + 1) = sArr1(i, 2)
Res(k, j + 2) = sArr1(i, 3)
For i2 = n2 To UBound(sArr2)
If sArr2(i2, 1) < tmp Then
If sArr2(i2, 1) > sArr1(i, 1) Then k = k + 1
Res(k, j2) = sArr2(i2, 1)
Res(k, j2 + 1) = sArr2(i2, 2)
Res(k, j2 + 2) = sArr2(i2, 3)
Else
n2 = i2: Exit For
End If
Next i2
Next i
With Sheets("KQ")
i = .Range("A" & Rows.Count).End(xlUp).Row
i2 = .Range("D" & Rows.Count).End(xlUp).Row
If i < i2 Then i = i2
If i > 1 Then .Range("A2:F" & i).Clear
.Range("A2").Resize(k).NumberFormat = "@"
.Range("D2").Resize(k).NumberFormat = "@"
.Range("A2").Resize(k, 6) = Res
End With
End SubEm thấy hình như code vẫn có động tác sortlist hay sao ấy ạ. Vì khi em áp dụng code này vào 1 bảng tương tự nhưng không ra kết quả như mong muốn. Anh xem giúp em với. Cảm ơn anh
File dữ liệu chưa sort, phải dùng code bài #26
Dữ liệu Mã data có trùng, code bài #26 đã loại trùng mã
Trước khi post bài , Em đã chạy code của #26 anh à. Nhưng file mới này của em không được phép loại trùng mã vì cần đối chiếu các phiếu Nhập kho (NK) với nhau. Và Em đã sort từ bên ngoài theo số phiếu nhập A-Z và sort mã A-Z.
Chỉ xét mã, chưa xét phiếu và số lượng
Sub RoundedRectangle4_Click()
'Sub SoSanh()
Dim sArr1(), sArr2(), Res()
Dim k As Long, eRow As Long, sRow As Long, n2 As Long
Dim i As Long, j As Long, i2 As Long, j2 As Long
With Sheets("Data")
i = .Range("A" & Rows.Count).End(xlUp).Row
i2 = .Range("D" & Rows.Count).End(xlUp).Row
If i > i2 Then eRow = i Else eRow = i2
Res = .Range("A2:F" & eRow).Value
End With
Application.ScreenUpdating = False
With Sheets("KQ")
.Range("A1").CurrentRegion.Offset(1).ClearContents
.Range("A2").Resize(i + i2).NumberFormat = "@"
.Range("D2").Resize(i + i2).NumberFormat = "@"
.Range("A2:F" & eRow) = Res
.Range("A1:C" & i).Sort .[A1], 1, .[B1], , 1, .[C1], , 1, Header:=xlYes
.Range("D1:F" & i2).Sort .[D1], 1, .[E1], , 1, .[F1], , 1, Header:=xlYes
i = .Range("A" & Rows.Count).End(xlUp).Row
i2 = .Range("D" & Rows.Count).End(xlUp).Row
If .Range("A2").Value <= .Range("A2").Value Then
sArr1 = .Range("A2:C" & i).Value
sArr2 = .Range("D2:F" & i2).Value
j = 1: j2 = 4
Else
sArr2 = .Range("A2:C" & i).Value
sArr1 = .Range("D2:F" & i2).Value
j = 4: j2 = 1
End If
End With
sRow = UBound(sArr1)
ReDim Res(1 To sRow + UBound(sArr2), 1 To 6)
n2 = 1
For i = 1 To sRow
k = k + 1
Res(k, j) = sArr1(i, 1)
Res(k, j + 1) = sArr1(i, 2)
Res(k, j + 2) = sArr1(i, 3)
If i < sRow Then tmp = sArr1(i + 1, 1) Else tmp = "zzz"
If tmp > sArr1(i, 1) Then
For i2 = n2 To UBound(sArr2)
If sArr2(i2, 1) < tmp Then
If sArr2(i2, 1) > sArr1(i, 1) Then k = k + 1
Res(k, j2) = sArr2(i2, 1)
Res(k, j2 + 1) = sArr2(i2, 2)
Res(k, j2 + 2) = sArr2(i2, 3)
Else
n2 = i2: Exit For
End If
Next i2
Else
If sArr2(n2, 1) = tmp Then
Res(k, j2) = sArr2(n2, 1)
Res(k, j2 + 1) = sArr2(n2, 2)
Res(k, j2 + 2) = sArr2(n2, 3)
n2 = n2 + 1
End If
End If
Next i
With Sheets("KQ")
.Range("A2").Resize(k, 6) = Res
End With
Application.ScreenUpdating = True
End SubĐúng là em chỉ cần so khớp mã để nhảy dòng. Nhưng Vì trước khi đưa dữ liệu vào sheet Data em đã làm sort từ các sheet gốc rồi, nên khi chạy code không muốn bị sort nữa, em đã xem code #36 , thử ngừng chạy các dòng liên quan đến sort như 2 dòng này:
nhưng mà kết quả ra rất khác so với mong muốn.
Kiểm tra lại
Dim Res(), sArr2(), k As Long, j2 As Long
Sub RoundedRectangle6_Click()
Dim sArr1(), tmp As String, dk As Boolean
Dim i As Long, j As Long, q As Long, sRow As Long
Dim i2 As Long, n2 As Long, q2 As Long
With Sheets("Data")
If .Range("A2").Value <= .Range("D2").Value Then
sArr1 = .Range("A2:C" & .Range("A" & Rows.Count).End(xlUp).Row).Value
sArr2 = .Range("D2:F" & .Range("D" & Rows.Count).End(xlUp).Row).Value
j = 1: j2 = 4
Else
sArr2 = .Range("A2:C" & .Range("A" & Rows.Count).End(xlUp).Row).Value
sArr1 = .Range("D2:F" & .Range("D" & Rows.Count).End(xlUp).Row).Value
j = 4: j2 = 1
End If
End With
Application.ScreenUpdating = False
sRow = UBound(sArr1)
ReDim Res(1 To sRow + UBound(sArr2), 1 To 6)
k = 0: n2 = 1
For i = 1 To sRow
If Len(sArr1(i, 1)) Then
k = k + 1
Res(k, j) = sArr1(i, 1)
Res(k, j + 1) = sArr1(i, 2)
Res(k, j + 2) = sArr1(i, 3)
tmp = "zzz"
For q = i + 1 To sRow
If Len(sArr1(q, 1)) Then tmp = sArr1(q, 1): Exit For
Next q
If tmp <> sArr1(i, 1) Then
dk = False
For i2 = n2 To UBound(sArr2)
If sArr2(i2, 1) = sArr1(i, 1) And sArr2(i2, 2) = sArr1(i, 2) And sArr2(i2, 3) = sArr1(i, 3) Then
If dk = True Then k = k + 1
Call GanKetQua(i2)
sArr2(i2, 1) = ""
dk = True
End If
If sArr2(i2, 1) = tmp Then
For q2 = n2 To i2 - 1
If Len(sArr2(q2, 1)) Then
If sArr2(q2, 1) <> sArr1(i, 1) Then k = k + 1
Call GanKetQua(q2)
End If
Next q2
n2 = i2: Exit For
End If
Next i2
Else
If sArr2(n2, 1) = tmp Then
Call GanKetQua(n2)
n2 = n2 + 1
End If
End If
End If
Next i
With Sheets("KQ")
i = .Range("A" & Rows.Count).End(xlUp).Row
i2 = .Range("D" & Rows.Count).End(xlUp).Row
If i2 > i Then i = i2
If i > 1 Then .Range("A2:F" & i).ClearContents
.Range("A2").Resize(k, 6) = Res
End With
Application.ScreenUpdating = True
End Sub
Private Sub GanKetQua(ByVal m As Long)
Res(k, j2) = sArr2(m, 1)
Res(k, j2 + 1) = sArr2(m, 2)
Res(k, j2 + 2) = sArr2(m, 3)
End Subhttps://www.mediafire.com/file/e1b1l6fuxtnbbe0/Sapxedulieu2.rar/fileCode bài #38 dòng đầu và cuối chưa chuẩn, khi rảnh mình viết thêm
Em cảm ơn anh. Code của anh ra đúng với kết quả mong muốn ở bài này rồi ạ.
Kết quả mong muốn làm sao có vậy? Có thể phải xét thêm vài cột điều kiện mà trong file không có
Cảm ơn anh đã hỗ trợ em trong thời gian qua. Em cũng không biết diễn đạt sao cho ra vấn đề. Có lẽ để em làm 1 clip mô tả lại quá trình em làm thủ công. Và gửi lại sau anh nhé. Chúc anh sức khỏe dồi dào và gặp nhiều niềm vui.
Dữ liệu phải sort theo ưu tiên: Phiếu, Mã
Dim Res(), sArr(), sArr2()
Dim Phieu As String, Ma As String, sRow As Long, sRow2 As Long
Dim i As Long, i2 As Long, n2 As Long, k As Long
Sub Button1_Click1()
With Sheets("Data")
sArr = .Range("A2:C" & .Range("A" & Rows.Count).End(xlUp).Row + 1).Value
sArr2 = .Range("D2:F" & .Range("D" & Rows.Count).End(xlUp).Row).Value
End With
Application.ScreenUpdating = False
sRow = UBound(sArr) - 1
sRow2 = UBound(sArr2)
ReDim Res(1 To sRow + sRow2, 1 To 6)
k = 0: n2 = 1
For i = 1 To sRow
Phieu = UCase(sArr(i, 2))
If Phieu > UCase(sArr2(n2, 2)) Then
Call Nho
ElseIf Phieu = UCase(sArr2(n2, 2)) Then
Call Bang
Else
Call Lon
End If
If k = UBound(Res) - 1 Then Exit For
Next i
With Sheets("KQ")
i = .Range("A" & Rows.Count).End(xlUp).Row
i2 = .Range("D" & Rows.Count).End(xlUp).Row
If i2 > i Then i = i2
If i > 1 Then .Range("A2:F" & i).ClearContents
.Range("A2").Resize(k, 6) = Res
End With
Application.ScreenUpdating = True
End Sub
Private Sub Bang()
Ma = sArr(i, 1)
For i2 = n2 To sRow2
If UCase(sArr2(i2, 2)) = Phieu Then
If Len(sArr2(i2, 1)) > 0 Then
If Ma > sArr2(i2, 1) Then
k = k + 1: Call GanKetQua2(i2)
sArr2(i2, 1) = ""
ElseIf Ma = sArr2(i2, 1) Then
k = k + 1: Call GanKetQua1(i)
If sArr2(i2, 1) = sArr(i, 1) And UCase(sArr2(i2, 2)) = UCase(sArr(i, 2)) And sArr2(i2, 3) = sArr(i, 3) Then
Call GanKetQua2(i2)
sArr2(i2, 1) = "": Exit For
End If
Else
Exit For
End If
End If
Else
Exit For
End If
Next i2
If Phieu <> UCase(sArr(i + 1, 2)) Then
For i2 = n2 To sRow2
If UCase(sArr2(i2, 2)) = Phieu Then
If Len(sArr2(i2, 1)) > 0 Then
k = k + 1: Call GanKetQua2(i2)
End If
Else
n2 = i2: Exit For
End If
Next i2
End If
End Sub
Private Sub Lon()
Dim ik As Long
For ik = i To UBound(sArr1)
If Phieu = sArr1(ik, 2) Then
If Len(sArr1(ik, 1)) > 0 Then
k = k + 1
Call GanKetQua1(ik)
End If
Else
i = ik - 1: Exit For
End If
Next ik
End Sub
Private Sub Nho()
For i2 = n2 To UBound(sArr2)
If Phieu > sArr2(i2, 2) Then
If Len(sArr2(i2, 1)) > 0 Then
k = k + 1
Call GanKetQua2(i2)
End If
Else
n2 = i2: Exit For
End If
Next i2
End Sub
Private Sub GanKetQua1(ByVal m As Long)
Res(k, 1) = sArr(m, 1)
Res(k, 2) = sArr(m, 2)
Res(k, 3) = sArr(m, 3)
End Sub
Private Sub GanKetQua2(ByVal m As Long)
Res(k, 4) = sArr2(m, 1)
Res(k, 5) = sArr2(m, 2)
Res(k, 6) = sArr2(m, 3)
End SubCảm ơn anh; em sẽ kiểm tra rồi báo anh sau.
