Xem đúng ý bạn chưa nhé
Option Explicit
Sub ABC()
Dim Dic As Object
Dim Nguon(), Kq(), Key, ViTri, SoLan
Dim Dong, Irow, a As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Data")
Irow = .Range("A" & Rows.Count).End(xlUp).Row
Nguon = .Range("A3").Resize(Irow, 3).Value
End With
Irow = UBound(Nguon)
ReDim Kq(1 To Irow, 1 To 3)
For a = 1 To Irow - 1
If Nguon(a, 2) > 60 And Mid(Nguon(a, 3), 1, 1) = "T" Then
Key = Nguon(a, 1)
If Not Dic.exists(Key) Then
Dong = Dong + 1
SoLan = 1
Dic.Add Key, Dong
Kq(Dong, 1) = Key
Kq(Dong, 2) = SoLan
Kq(Dong, 3) = Nguon(a, 2)
Else
ViTri = Dic.Item(Key)
Kq(ViTri, 2) = Kq(ViTri, 2) + 1
Kq(ViTri, 3) = Kq(ViTri, 3) + Nguon(a, 2)
End If
End If
Next
With Sheets("Result")
If Dong > 0 Then
.Range("B3").Resize(Dong, 3).Value = Kq
End If
End With
End SubEm chưa biết cách dùng, cảm ơn bác đã gợi ý, em sẽ tìm hiểu thêm ạ
Code đã cho kết quả đúng như em muốn rồi, em cảm ơn bác nhiều ạ
Các ac giúp đỡ em bài toán này với. Em muốn lọc duy nhất từ sheet Xuất sang sheet Tdoi với tiêu chí: Lọc duy nhất theo mã hàng và tên nvien, rồi cổng tổng số lượng, thành tiền các lần xuất của mặt hàng đó bên sheet xuất
Bạn thử câu lệnh sau:
Option Explicit
Sub Z_Z()
Dim sheet As Worksheet
Dim dic As Object, Key As String
Dim Data As Variant, result As Variant
Dim strName As String, strItem As String
Dim r As Long, i As Long, j As Long, k As Long
Const delim As String = "|"
With ThisWorkbook.Worksheets("Xuat")
r = .Cells(.Rows.Count, "D").End(xlUp).Row
If r < 9 Then: MsgBox "Khong co du lieu.", vbCritical: Exit Sub
Data = .Range("B9:J" & r).Value
End With
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = TextCompare
ReDim result(1 To UBound(Data, 1), 1 To UBound(Data, 2))
For i = LBound(Data, 1) To UBound(Data, 1)
strName = Data(i, 1)
strItem = Data(i, 3)
Key = Join(Array(strName, strItem), delim)
If Not dic.Exists(Key) Then
k = k + 1
dic.Add Key, k
For j = LBound(Data, 2) To UBound(Data, 2)
result(k, j) = Data(i, j)
Next j
Else
r = dic.Item(Key)
For j = 6 To 9
result(r, j) = result(r, j) + Data(i, j)
Next j
End If
Next i
With ThisWorkbook.Worksheets("Tdoi")
r = .Cells(.Rows.Count, "C").End(xlUp).Row
If (r > 9) Then .Range("A9:K" & r).ClearContents
If (k > 0) Then .Range("A9").Resize(k, UBound(result, 2)).Value = result
End With
MsgBox "Ket thuc.", vbInformation
End SubEm cảm ơn ạ. ac có thể viết cho em xin thêm đoạn mã để sắp xếp. Sau đó thêm 1 hàng ngay dưới khi hết 1 người, rồi cộng tổng tiền người đó. Và cuối cùng thêm 1 dòng trên cùng hoặc cuối cùng để tổng cộng tiền doanh thu của cả bảng đựợc không? Nó lộn xộn quá ạ
Bạn muốn sắp xếp cột nào vậy?
File mới của bạn có các thông tin như:
Bạn kiểm tra lại:
Option Explicit
Public Sub returnSubTotal()
Dim dic As Object, ws As Worksheet, sheet As Worksheet
Dim Data As Variant, Result As Variant, Subtotal As Variant
Dim str As String, sMacNo As String, sMember As String, sGroup As String, sTotal As String
Dim i As Long, j As Long, k As Long, r As Long, n As Long, x As Long
Dim dDTT As Double, dPT As Double, dTT As Double, dN As Double, d As Double
Dim c As Integer, count As Integer
Application.ScreenUpdating = False
On Error GoTo Exit_
Set ws = ThisWorkbook.Worksheets("XL")
Set sheet = ThisWorkbook.Worksheets("TDOI")
With ThisWorkbook.Worksheets("XL")
r = .Cells(.Rows.count, "B").End(xlUp).Row
If r < 3 Then: MsgBox "Khong co du lieu.", vbCritical: Exit Sub
Result = ws.Range("A3:J" & r).Value
.Range("A3:J" & r).Sort _
Key1:=ws.Range("F3"), Order1:=xlAscending, _
Key2:=ws.Range("E3"), Order2:=xlAscending, _
Key3:=ws.Range("C3"), Order3:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlYes
.Range("A3:J" & r).Value = Result
Data = .Range("B3:J" & r).Value
End With
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = TextCompare
With ThisWorkbook.Worksheets("NHAP")
r = .Cells(.Rows.count, "B").End(xlUp).Row
If r < 3 Then GoTo ZZ
Result = .Range("B3:C" & r).Value
For i = LBound(Result, 1) To UBound(Result, 1)
sMacNo = Result(i, 1): dDTT = Result(i, 2)
If Not dic.Exists(sMacNo) Then
dic.Add sMacNo, Array(dDTT, 1)
Else
d = dic.item(sMacNo)(0) + dDTT
count = dic.item(sMacNo)(1) + 1
dic.item(sMacNo) = Array(d, count)
End If
Next i
End With
ZZ:
sTotal = "C" & ChrW(7897) & "ng: "
r = UBound(Data, 1): c = 12
ReDim Preserve Data(1 To r, 1 To c)
ReDim Result(1 To r, 1 To c)
ReDim Subtotal(1 To r, 1 To c)
For i = 1 To r
sMacNo = Data(i, 1)
sMember = Data(i, 4)
sGroup = Data(i, 5)
dPT = Data(i, 6)
dTT = Data(i, 7)
If dic.Exists(sMacNo) Then
dDTT = dic.item(sMacNo)(0)
count = dic.item(sMacNo)(1)
Else
dDTT = 0
count = 0
End If
str = sMacNo & "|" & sMember
dN = (dDTT + dTT) - dPT
If Not dic.Exists(sGroup) Then
n = n + 1
dic.Add sGroup, n
Subtotal(n, 4) = sTotal & sGroup
Subtotal(n, c) = n & sGroup & sTotal
Subtotal(n, 5) = dPT
Subtotal(n, 6) = dDTT
If (dN > 0) Then
Subtotal(n, 7) = 0
Subtotal(n, 8) = dN
Else
Subtotal(n, 7) = dPT - dDTT + dTT
Subtotal(n, 8) = 0
End If
Subtotal(n, 9) = count
Else
x = dic.item(sGroup)
Subtotal(x, 5) = Subtotal(x, 5) + dPT
Subtotal(x, 6) = Subtotal(x, 6) + dDTT
If (dN > 0) Then
Subtotal(x, 7) = Subtotal(x, 7) + 0
Subtotal(x, 8) = Subtotal(x, 8) + dN
Else
Subtotal(x, 7) = Subtotal(x, 7) + dPT - dDTT + dTT
Subtotal(x, 8) = Subtotal(x, 8) + 0
End If
Subtotal(n, 9) = Subtotal(n, 9) + 1
End If
If Not dic.Exists(str) Then
k = k + 1: dic.Add str, k
Result(k, 1) = k
For j = 1 To 3
Result(k, j + 1) = Data(i, j)
Next j
Result(k, 5) = dPT
Result(k, 6) = dDTT
If (dN > 0) Then
Result(k, 7) = 0
Result(k, 8) = dN
Else
Result(k, 7) = dPT - dDTT + dTT
Result(k, 8) = 0
End If
Result(k, 9) = count
Result(k, 10) = sMember
Result(k, 11) = sGroup
Result(i, c) = n & sGroup
Else
x = dic.item(str)
Result(x, 5) = Result(x, 5) + dPT
Result(x, 6) = Result(x, 6) + dDTT
If (dN > 0) Then
Result(x, 7) = Result(x, 7) + 0
Result(x, 8) = Result(x, 8) + dN
Else
Result(x, 7) = Result(x, 7) + dPT - dDTT + dTT
Result(x, 8) = Result(x, 8) + 0
End If
Result(x, 9) = Result(x, 9) + 1
End If
Next i
Dim bookTmp As Workbook, shTmp As Worksheet
Set bookTmp = Workbooks.Add
Set shTmp = bookTmp.Worksheets(1)
If (k > 0) Then shTmp.Range("A1").Resize(k, c).Value = Result
If (n > 0) Then shTmp.Range("A" & k + 1).Resize(n, c).Value = Subtotal
r = k + n
If r = 0 Then GoTo End_
With shTmp.Sort
.SortFields.Clear
.SortFields.Add key:=shTmp.Cells(1, c), Order:=xlAscending
.SetRange shTmp.Range("A1").Resize(r, c)
.Header = xlYes
.Apply
End With
Subtotal = shTmp.Range("A1").Resize(r, c - 1)
k = 0
For i = LBound(Subtotal, 1) To UBound(Subtotal, 1)
If Len(Subtotal(i, 1)) > 0 Then
k = k + 1
Subtotal(i, 1) = k
End If
Next i
End_:
If Not bookTmp Is Nothing Then bookTmp.Close False
Application.ScreenUpdating = True
sheet.Range("N3").Resize(UBound(Subtotal, 1), UBound(Subtotal, 2)).Value = Subtotal
MsgBox "Ket thuc.", vbInformation
Exit Sub
Exit_:
Application.ScreenUpdating = True
End SubDạ trong khả năng của OT thì là vậy ạ,
Thêm cho bạn một cách khác nhé:
Sub Dem_HLMT()
With CreateObject("ADODB.Connection")
.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=No"""
Sheet2.Range("B10").CopyFromRecordset .Execute("Select F1, Count(F1),Sum(F2) From [Data$A3:C] Where F2>60 And F3 Like '" & Sheet1.Range("C3") & "' Group By F1")
End With
End SubEm thật lòng xin lỗi các ac, Cảm ơn các ac đã giúp đỡ. Thực tâm em muốn kết quả như Sheet TDoi dưới đây. Vì là đang hỏi dở bài số #5, nhưng vì tiện file đang có sẵn nên gửi và ngụ ý muốn giống như vậy, chứ không có ý làm trên file bài #10 đó.
Chít chưa mấy anh chị!
E cũng theo dõi suốt nhưng không thấy ai hỏi, thế nên mải làm, công việc của em là trên đường nên không kịp trả lời. Đến khi xem lại thì thấy các ac đã giúp đỡ. Em xin cảm ơn ạ.
Dạ, dạ, cho em xin lỗi ạ
Cái tiện của bạn & cái file có sẵn đó với mình cũng chóng mặt lắm đó
.Option Explicit
Sub Z_Z()
Dim sheet As Worksheet, rng As Range
Dim dic As Object, Key As String
Dim Data As Variant, subToltal As Variant, result As Variant
Dim strName As String, strItem As String, dbMoney As Double, dbTotal As Double
Dim r As Long, i As Long, j As Long, k As Long, n As Long
Dim c As Integer
With ThisWorkbook.Worksheets("Xuat")
r = .Cells(.Rows.count, "D").End(xlUp).Row
If r < 9 Then: MsgBox "Khong co du lieu.", vbCritical: Exit Sub
Set rng = .Range("A9:L" & r): result = rng.Value
rng.Sort Key1:=.Range("B9"), Order1:=xlAscending, Key2:=.Range("D9"), Order2:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlNo
Data = .Range("B9:J" & r).Value
rng.Value = result
End With
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = vbTextCompare
c = UBound(Data, 2) + 1
ReDim result(1 To UBound(Data, 1), 1 To c)
ReDim subToltal(1 To UBound(Data, 1), 1 To c)
For i = LBound(Data, 1) To UBound(Data, 1)
strName = Data(i, 1)
strItem = Data(i, 3)
dbMoney = Data(i, 9)
Key = strName & "|" & strItem
dbTotal = dbTotal + dbMoney
If Not dic.Exists(Key) Then
k = k + 1: dic.Add Key, k
If Not dic.Exists(strName) Then
n = n + 1: dic.Add strName, n
subToltal(n, 1) = "C" & ChrW(7897) & "ng: "
subToltal(n, c) = n & strName & "C" & ChrW(7897) & "ng: "
subToltal(n, 9) = dbMoney
Else
r = dic.Item(strName)
subToltal(r, 9) = subToltal(r, 9) + dbMoney
End If
For j = LBound(Data, 2) To UBound(Data, 2)
result(k, j) = Data(i, j)
Next j
result(k, c) = n & strName & "C" & ChrW(7897) & "ng: "
Else
r = dic.Item(Key)
For j = 6 To 9
result(r, j) = result(r, j) + Data(i, j)
Next j
r = dic.Item(strName)
subToltal(r, 9) = subToltal(r, 9) + dbMoney
End If
Next i
With ThisWorkbook.Worksheets("Tdoi")
r = .Cells(.Rows.count, "A").End(xlUp).Row
If (r > 9) Then .Range("A9:K" & r).ClearContents
If (k > 0) Then .Range("A9").Resize(k, UBound(result, 2)).Value = result
If (n > 0) Then .Range("A9").Offset(k).Resize(n, UBound(subToltal, 2)).Value = subToltal
r = 8 + k + n: Set rng = .Range("A9:K" & r)
rng.Sort Key1:=.Range("J9"), Order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlNo
.Range("J9:J" & r).ClearContents
.Range("J9:J" & r).ClearContents
.Range("A" & r + 1).Value = "T" & ChrW(7893) & "ng c" & ChrW(7897) & "ng:"
.Range("I" & r + 1).Value = dbTotal
End With
MsgBox "Ket thuc.", vbInformation
End SubDạ, cho em xin lỗi ạ.
Dạ, em lắp vào code chạy rất tốt ạ. E chả biết nói gì nữa, xin gửi đến ac và diễn đàn ời cảm ơn ạ. Chúc anh chị mạnh khỏe.
Mà file ac làm cho em quá hoàn chỉnh rồi ạ. em thấy hơn cả mong đợi rồi ạ. E xin cảm ơn ac.
