Bạn xem thử. . . .
File em gửi lên là file mẫu, file thực tế hơn hai nghìn dòng, công thức nhiều file chạy chậm. Cảm ơn anh đã hỗ trợ. Em muốn nhờ giúp em code tương tự như bài này: https://www.giaiphapexcel.com/diendan/threads/nhờ-giúp-code-lọc-báo-cáo-theo-điều-kiện-từ-2-bảng-dữ-liệu.160363/
Bạn xem thử. . . .
Anh giúp em khi nhấn nút cập nhật sẽ không làm mất dữ liệu các dòng em có ghi Data. Các dòng này cùng dòng với các ô có chữ SL M và LK ở cột H sheet "KH"
Đoạn này mình ... chưa biết làm.
Bạn tạo một module mới rồi copy toàn bộ code bên dưới vào , sau đó chạy thử "Sub Test" :
Option Explicit
Public Function LastRowInOneColumn(ByVal sheet As Worksheet, ByVal sCol As String)
Dim lstobj As Object
With sheet
For Each lstobj In .ListObjects
If lstobj.ShowAutoFilter Then
lstobj.Range.AutoFilter
lstobj.Range.AutoFilter
End If
Next lstobj
If .AutoFilterMode = True Then .AutoFilterMode = False
LastRowInOneColumn = .Cells(.Rows.Count, sCol).End(xlUp).Row
End With
End Function
Public Function LastColumnInOneRow(ByVal sheet As Worksheet, ByVal iRow As Long)
Dim lstobj As Object
With sheet
For Each lstobj In .ListObjects
If lstobj.ShowAutoFilter Then
lstobj.Range.AutoFilter
lstobj.Range.AutoFilter
End If
Next lstobj
If .AutoFilterMode = True Then .AutoFilterMode = False
LastColumnInOneRow = .Cells(iRow, .Columns.Count).End(xlToLeft).Column
End With
End Function
Sub Test()
Dim dict As Object
Dim shTGGH As Worksheet, shKH As Worksheet
Dim Data As Variant, Result As Variant
Dim sKEY As String
Dim c As Long, r As Long, i As Long, j As Long
Dim orderDate As Date
Dim dbQuantity As Double
Const DELIM = "|"
Set shTGGH = ThisWorkbook.Worksheets("TG GH")
Set shKH = ThisWorkbook.Worksheets("KH")
r = LastRowInOneColumn(shKH, "H")
c = LastColumnInOneRow(shKH, 10)
If (r < 11) Or (c < 21) Then
MsgBox "Du lieu khong phu hop,hay kiem tra lai sheet " & shKH.Name, _
vbCritical + vbOKOnly
Exit Sub
End If
Result = shKH.Range("A10:A" & r).Resize(, c).Value
r = LastRowInOneColumn(shTGGH, "J")
If (r < 11) Then
MsgBox "Du lieu khong phu hop,hay kiem tra lai sheet " & shTGGH.Name, _
vbCritical + vbOKOnly
Exit Sub
End If
Data = shTGGH.Range("A11:Q" & r).Value
Set dict = CreateObject("Scripting.Dictionary")
For j = 21 To UBound(Result, 2)
If IsDate(Result(1, j)) Then
orderDate = Result(1, j)
If Not dict.Exists(orderDate) Then dict.Add orderDate, j
End If
Next j
For i = 2 To UBound(Result, 1) Step 3
sKEY = Join(Array(Result(i, 2), Result(i, 7), Result(i, 8)), DELIM)
If Not dict.Exists(sKEY) Then dict.Add sKEY, i
Result(i, 19) = Empty
For j = 21 To UBound(Result, 2)
Result(i, j) = Empty
Next j
Next i
For i = LBound(Data, 1) To UBound(Data, 1)
sKEY = Join(Array(Data(i, 2), Data(i, 5), Data(i, 10)), DELIM)
orderDate = Data(i, 12): dbQuantity = Data(i, 17)
r = dict.Item(sKEY): c = dict.Item(orderDate)
If (r > 0) And (c > 0) Then
Result(r, c) = Result(r, c) + dbQuantity
Result(r, 19) = Result(r, 19) + dbQuantity
End If
Next i
shKH.Range("A10").Resize(UBound(Result, 1), UBound(Result, 2)).Value = Result
MsgBox "Xong roi!", vbInformation + vbOKOnly
End SubKết quả đúng rồi Anh, em cảm ơn Anh. Chúc Anh thật nhiều sức khỏe.
Anh giúp em khi nhấn nút cập nhật (TEST) sẽ không làm mất các ô, các cột có chứa công thức, mong Anh giúp em. Em cảm ơn
Đúng như mình đã nghĩ,khi gửi code mình cũng đoán kiểu gì các ô bạn không muốn thay đổi đó là các ô có công thức, nên khả năng cao bạn sẽ hỏi tiếp.
Đúng như mình đã nghĩ,khi gửi code mình cũng đoán kiểu gì các ô bạn không muốn thay đổi đó là các ô có công thức, nên khả năng cao bạn sẽ hỏi tiếp.
Muốn giữ công thức thì cũng được bạn,phải sửa lại code thôi từ đi máy bay sang đi bộ vậy
Hoặc nếu bạn vẫn muốn đi máy bay thì phải chấp nhận thay các ô công thức đó để code xử lý.
Em cảm ơn Anh nhiều.Đúng như mình đã nghĩ,khi gửi code mình cũng đoán kiểu gì các ô bạn không muốn thay đổi đó là các ô có công thức, nên khả năng cao bạn sẽ hỏi tiếp.
Muốn giữ công thức thì cũng được bạn,phải sửa lại code thôi từ đi máy bay sang đi bộ vậy
Hoặc nếu bạn vẫn muốn đi máy bay thì phải chấp nhận thay các ô công thức đó để code xử lý.
Bạn xóa 'Sub Test' ở bài 7 thay bằng code dưới, các Function khác ở bài 7 giữ không xóa.
Sub Test()
Dim dict As Object
Dim shTGGH As Worksheet, shKH As Worksheet
Dim Result As Range, cell As Range, rUnion As Range
Dim Data As Variant
Dim sKEY As String
Dim c As Long, r As Long, i As Long, j As Long
Dim orderDate As Date
Dim dbQuantity As Double
Const DELIM = "|"
Set shTGGH = ThisWorkbook.Worksheets("TG GH")
Set shKH = ThisWorkbook.Worksheets("KH")
r = LastRowInOneColumn(shKH, "H")
c = LastColumnInOneRow(shKH, 10)
If (r < 11) Or (c < 21) Then
MsgBox "Du lieu khong phu hop,hay kiem tra lai sheet " & shKH.Name, _
vbCritical + vbOKOnly
Exit Sub
End If
Set Result = shKH.Range("A10:A" & r).Resize(, c)
r = LastRowInOneColumn(shTGGH, "J")
If (r < 11) Then
MsgBox "Du lieu khong phu hop,hay kiem tra lai sheet " & shTGGH.Name, _
vbCritical + vbOKOnly
Exit Sub
End If
Data = shTGGH.Range("A11:Q" & r).Value
Set dict = CreateObject("Scripting.Dictionary")
For j = 21 To c
If IsDate(Result(1, j)) Then
orderDate = Result(1, j)
If Not dict.Exists(orderDate) Then dict.Add orderDate, j
End If
Next j
For i = 2 To Result.Rows.Count Step 3
sKEY = Join(Array(Result(i, 2), Result(i, 7), Result(i, 8)), DELIM)
If Not dict.Exists(sKEY) Then dict.Add sKEY, i
Set cell = Union(Result(i, 19), Result(i, 21).Resize(, c - 20))
If Not rUnion Is Nothing Then Set rUnion = Union(rUnion, cell) Else Set rUnion = cell
Next i
If Not rUnion Is Nothing Then rUnion.ClearContents
For i = LBound(Data, 1) To UBound(Data, 1)
sKEY = Join(Array(Data(i, 2), Data(i, 5), Data(i, 10)), DELIM)
orderDate = Data(i, 12): dbQuantity = Data(i, 17)
r = dict.Item(sKEY): c = dict.Item(orderDate)
If (r > 0) And (c > 0) Then
Result(r, c) = Result(r, c) + dbQuantity
Result(r, 19) = Result(r, 19) + dbQuantity
End If
Next i
MsgBox "Xong roi!", vbInformation + vbOKOnly
End SubAnh ơi, kết quả tổng số lượng giao hàng chênh lệch với số lượng sheet "TG GH", Anh chỉnh code giúp em thêm tí nữa để tổng đúng luôn ạ, những chỗ khác đúng hết rồi Anh. Em cảm ơn.
Bạn thử dùng công thức sumifs để kiểm tra lại xác xuất một vài mã nhé bạn.
Em check thấy có một số mã chênh lệch, Anh xem giúp em với.
Xin lỗi bạn, đúng là tôi copy nên sơ xuất.
Kết quả đúng rồi ạ. Em cảm ơn. Anh rất giỏi, chúc Anh thành công.
