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
