Thử code.
Sub congviec()
Dim i As Long, lr As Long, dic As Object, a As Long, dk As String, dks As String, b As Long, arr, kq
Set dic = CreateObject("scripting.dictionary")
With Sheets("TK")
lr = .Range("A" & Rows.Count).End(xlUp).Row
arr = .Range("A2:B" & lr).Value
ReDim kq(1 To UBound(arr), 1 To 3)
For i = 1 To UBound(arr)
dk = arr(i, 2)
If Not dic.exists(dk) Then
a = a + 1
dic.Add dk, a
kq(a, 1) = arr(i, 2)
kq(a, 2) = 1
kq(a, 3) = arr(i, 1)
Else
b = dic.Item(dk)
dks = "," & arr(i, 1) & ","
If InStr(1, "," & kq(b, 3) & ",", dks) = 0 Then
kq(b, 3) = kq(b, 3) & "," & arr(i, 1)
kq(b, 2) = kq(b, 2) + 1
End If
End If
Next i
lr = .Range("E" & Rows.Count).End(xlUp).Row
If lr > 1 Then .Range("E2:G" & lr).ClearContents
If a Then .Range("e2:g2").Resize(a).Value = kq
End With
End SubCảm ơn bạn đã giúp đỡ, phiền bạn có thể sửa giúp cột công việc (cột E) để nhập tay được không, nghĩa là nhập tay công việc nào thì dữ liệu sẽ tìm kiếm và điền theo công việc đó, chứ không phải là liệt kê hết công việc ạ.
Cột F hàm COUNTIF
Bạn thử xem file
Bạn thử.
Sub congviec()
Dim i As Long, lr As Long, dic As Object, a As Long, dk As String, dks As String, b As Long, arr, kq, lr1
Set dic = CreateObject("scripting.dictionary")
With Sheets("TK")
lr = .Range("E" & Rows.Count).End(xlUp).Row
If lr < 1 Then Exit Sub
.Range("F2:G" & lr).ClearContents
kq = .Range("E2:G" & lr).Value
For i = 1 To UBound(kq)
dk = kq(i, 1)
dic.Item(dk) = i
Next i
lr1 = .Range("A" & Rows.Count).End(xlUp).Row
arr = .Range("A2:B" & lr1).Value
For i = 1 To UBound(arr)
dk = arr(i, 2)
If dic.exists(dk) Then
b = dic.Item(dk)
dks = "," & arr(i, 1) & ","
If kq(b, 3) = Empty Then
kq(b, 3) = arr(i, 1)
kq(b, 2) = 1
ElseIf InStr(1, "," & kq(b, 3) & ",", dks) = 0 Then
kq(b, 3) = kq(b, 3) & "," & arr(i, 1)
kq(b, 2) = kq(b, 2) + 1
End If
End If
Next i
.Range("e2:g" & lr).Value = kq
End With
End SubNếu đã dùng power pivot thì nên để source gốc trong Data model rồi dùng Dax xử lý, chứ bạn dùng PQ xử lý thì nó trả về cho 1 trường hợp riêng lẽ, thống kê cho các trường hợp khác thì lại phải tạo source khác từ source gốc rất bất tiện, bạn xem thử!
Các hàm DAX mình chưa biết nhiều, chỉ biết 1 số hàm cơ bản nên mới phải dùng PQ để loại trùng. Trước giờ xử lý nối chuỗi loại trùng toàn phải dùng PQ, nay biết thêm hàm DISTINCT
Nên tìm hiểu bạn ạ, các hàm Dax tượng tự excel và dễ hơn excel, nhưng với những người rành về mảng excel sẽ khó tiếp cận hơn những người chưa biết excel vì có thể xem Dax là dynamic array, nhưng khi tiếp cận rồi thì nó hấp dẫn hơn excel, Dax là rễ của Power pivot và power BI nên nó sẽ mang lại rất nhiều lợi ích cho bạn trong công việc so với cách làm bây giờ.
Tiếp cận DAX thì nên tiếp cận theo hướng cơ sở dữ liệu, cụ thể các TABLE, FIELDs (Columns), hay RECORDs (Rows) - là phép tính với các đối tượng đó - nó tổng quan và trừu tượng hơn chút so với hàm excel chỉ đối với cell và range.
Dax xử lý custom table và custom column không có Custom Row và Cells, nhưng chỉ cần vậy là làm được hết nhưng phải rành về dynamic array điều kiện filter và hoàn cảnh filter, đôi khi không sử dụng hàm mảng nó vẫn biến đổi bởi vậy tôi mới nói những người rành về mảng bên excel qua Dax sẽ bị hố nếu vẫn giữ tư duy của mảng excel, Dax có thể xử lý mọi Case mà không cần dùng tới M trong PQ, chỉ có các trường hợp đệ quy mới cần dùng M nhưng nếu cần xử lý vậy thì làm ngay data gốc luôn chứ chẳng cần PQ xử lý
Cảm ơn các bạn đã giúp đỡ tôi, code trên của bạn đúng với những gì tôi cần.
Bạn dùng power pivot phiên bản năm bao nhiêu thế ạ
Tôi đang sài power pivot của office 365 bạn ạ
Bạn thử code này nhé.
Sub congviec()
Dim i As Long, lr As Long, dic As Object, a As Long, dk As String, dks As String, b As Long, arr, kq, s As String
Set dic = CreateObject("scripting.dictionary")
With Sheets("TK")
lr = .Range("A" & Rows.Count).End(xlUp).Row
arr = .Range("A2:C" & lr).Value
ReDim Preserve arr(1 To UBound(arr), 1 To 4)
For i = 1 To UBound(arr)
dk = arr(i, 2) & "#" & arr(i, 1)
If Not dic.exists(dk) Then
dic.Add dk, i
arr(i, 4) = arr(i, 3)
Else
b = dic.Item(dk)
arr(b, 4) = arr(i, 3) + arr(b, 4)
End If
Next i
For i = 1 To UBound(arr)
dk = arr(i, 2)
If Not dic.exists(dk) Then
If arr(i, 4) = 1 Then
s = arr(i, 1)
Else
s = arr(i, 1) & "[" & arr(i, 4) & "]"
End If
dic.Add dk, Array(1, s)
Else
a = dic.Item(dk)(0)
s = dic.Item(dk)(1)
If arr(i, 4) > 0 Then
a = a + 1
If arr(i, 4) = 1 Then
s = s & "," & arr(i, 1)
Else
s = s & "," & arr(i, 1) & "[" & arr(i, 4) & "]"
End If
End If
dic.Item(dk) = Array(a, s)
End If
Next i
lr = .Range("E" & Rows.Count).End(xlUp).Row
If lr > 1 Then .Range("F2:G" & lr).ClearContents
kq = .Range("E2:G" & lr).Value
For i = 1 To UBound(kq)
dk = kq(i, 1)
If dic.exists(dk) Then
kq(i, 2) = dic.Item(dk)(0)
kq(i, 3) = dic.Item(dk)(1)
End If
Next i
.Range("E2:G" & lr).Value = kq
End With
End SubCảm ơn bạn, tôi thử code trên thấy có mã NV không ra điểm số ví dụ: NV0038,NV0041,NV0043,NV0045, tại CV10.
Thế nó bằng 1 rồi còn ra gì nữa.Ở trên cũng như vậy không thì sửa code như sau.
Sub congviec()
Dim i As Long, lr As Long, dic As Object, a As Long, dk As String, dks As String, b As Long, arr, kq, s As String
Set dic = CreateObject("scripting.dictionary")
With Sheets("TK")
lr = .Range("A" & Rows.Count).End(xlUp).Row
arr = .Range("A2:C" & lr).Value
ReDim Preserve arr(1 To UBound(arr), 1 To 4)
For i = 1 To UBound(arr)
dk = arr(i, 2) & "#" & arr(i, 1)
If Not dic.exists(dk) Then
dic.Add dk, i
arr(i, 4) = arr(i, 3)
Else
b = dic.Item(dk)
arr(b, 4) = arr(i, 3) + arr(b, 4)
End If
Next i
For i = 1 To UBound(arr)
dk = arr(i, 2)
If Not dic.exists(dk) Then
s = arr(i, 1) & "[" & arr(i, 4) & "]"
dic.Add dk, Array(1, s)
Else
a = dic.Item(dk)(0)
s = dic.Item(dk)(1)
If arr(i, 4) > 0 Then
a = a + 1
s = s & "," & arr(i, 1) & "[" & arr(i, 4) & "]"
End If
dic.Item(dk) = Array(a, s)
End If
Next i
lr = .Range("E" & Rows.Count).End(xlUp).Row
If lr > 1 Then .Range("F2:G" & lr).ClearContents
kq = .Range("E2:G" & lr).Value
For i = 1 To UBound(kq)
dk = kq(i, 1)
If dic.exists(dk) Then
kq(i, 2) = dic.Item(dk)(0)
kq(i, 3) = dic.Item(dk)(1)
End If
Next i
.Range("E2:G" & lr).Value = kq
End With
End Sub
Bác có thể chỉ giúp làm thế nào để nối chuỗi vậy không? Em dùng office 2010, có tải power pivot về rồi nhưng đến đoạn nối chuỗi em chịu (em chưa dùng cái này bao giờ). File của bác thì phiên bản máy của em lại không mở chi tiết ra xem được
Office 2010 em cài thêm power pivot mà không thấy hàm concatenatex
Có thể rút bớt 1 for được không bạn?
Chắc là power pivot phiên bản cũ nó không có hàm đó, bạn thử xem trên máy nào có phiên bản office cao hơn thử xem.
Vâng bác, để em về cài trên máy ở nhà xem sao. Em cũng muốn biết thêm cái này chứ đi làm office cũ nên ít khi được tiếp cận
Mình cũng thế, mình còn không làm được như bạn nên mình mới hỏi.
Tôi thì không hiểu đề bài muốn gì, để mà rút gọn
Hihi, cảm ơn bạn nhiều do nhu cầu công việc nên tôi muốn sửa đổi bổ sung cho rõ ràng hơn.
Bạn không hiểu chỗ nào vậy, để tôi giải thích thêm ạ?
Chạy code
Sub XYZ()
Dim dic As Object, sArr(), aCV(), Arr As Variant, Res()
Dim sRow&, i&, k&, ik&, iKey$, iKey2$, tmp$
Set dic = CreateObject("scripting.dictionary")
With Sheets("TK")
sArr = .Range("A2", .Range("C" & Rows.Count).End(xlUp)).Value
aCV = .Range("E2", .Range("E" & Rows.Count).End(xlUp)).Value
End With
sRow = UBound(sArr)
ReDim Preserve sArr(1 To sRow, 1 To 4)
For i = 1 To sRow
iKey2 = sArr(i, 2)
If Not dic.exists(iKey2) Then dic.Add iKey2, Array(0, ",")
Arr = dic.Item(iKey2)
iKey = sArr(i, 2) & "#" & sArr(i, 1)
If Not dic.exists(iKey) Then
dic.Add iKey, i
If sArr(i, 3) = 1 Then sArr(i, 4) = sArr(i, 1) Else sArr(i, 4) = sArr(i, 1) & "[" & sArr(i, 3) & "]"
Arr(0) = Arr(0) + 1
Arr(1) = Arr(1) & sArr(i, 4) & ","
Else
ik = dic.Item(iKey)
sArr(ik, 3) = sArr(i, 3) + sArr(ik, 3)
If sArr(ik, 3) = 1 Then tmp = sArr(i, 1) Else tmp = sArr(i, 1) & "[" & sArr(ik, 3) & "]"
Arr(1) = Replace(Arr(1), "," & sArr(ik, 4) & ",", "," & tmp & ",")
sArr(ik, 4) = tmp
End If
dic.Item(iKey2) = Arr
Next i
sRow = UBound(aCV)
ReDim Res(1 To sRow, 1 To 2)
For i = 1 To sRow
iKey2 = aCV(i, 1)
If dic.exists(iKey2) Then
Arr = dic.Item(iKey2)
Res(i, 1) = Arr(0)
Res(i, 2) = Mid(Arr(1), 2, Len(Arr(1)) - 2)
End If
Next i
Sheets("TK").Range("F2").Resize(sRow, 2) = Res
End SubCảm ơn bạn rất nhiều, tôi thử code, kết quả không lấy lấy được những số lượng =1 giống như bài 17 bạn xem giúp ạ.
2 code kết quả giống i sì mờ
Mình chạy thử có thấy khác phần số điểm là 1 mà bạn.
Nếu dùng Power pivot không qua trung gian Power query sao bạn không nhấn nút Add to Data Model ngay trên Ribbon luôn?
Office 2010 là Create linked table
Chào Bác em mới học vba,Có thắc mắc mong Bác giải thích cho.Em thấy các Bác khai bảo biến Dim sRow&, i&, k&, ik&, iKey$, iKey2$, tmp$ có thêm & , $ vậy Bác cho hỏi là các ký tự này có ý nghĩa,chức năng gì đặc biệt trong code không hay là để dễ phân biệt các biến ạ?
Lúc trước tôi thường connect trực tiếp từ data model, nhưng connect trực tiếp vậy có nhiều hạn chế, không append, merged, dynamic query.... được nên tôi chuyển sang connect bằng PQ trước sau đó mới add vào data model, sau này làm nhiều rồi quen mặc dù không có edit gì.
Mục đích giảm số ký tự khai báo
Thử file nào ?
Xem công thức kiểm tra trong file
Cảm ơn bạn đã làm thêm chức năng so sánh giúp mình dễ quan sát, code mình lấy của bạn Snow25 là code ở bài 18 bạn ạ.
Xóa bớt vài lệnh
Sub XYZ()
Dim dic As Object, sArr(), aCV(), arr As Variant, Res()
Dim sRow&, i&, k&, ik&, iKey$, iKey2$, tmp$
Set dic = CreateObject("scripting.dictionary")
With Sheets("TK")
sArr = .Range("A2", .Range("C" & Rows.Count).End(xlUp)).Value
aCV = .Range("E2", .Range("E" & Rows.Count).End(xlUp)).Value
End With
sRow = UBound(sArr)
ReDim Preserve sArr(1 To sRow, 1 To 4)
For i = 1 To sRow
iKey2 = sArr(i, 2)
If Not dic.exists(iKey2) Then dic.Add iKey2, Array(0, ",")
arr = dic.Item(iKey2)
iKey = sArr(i, 2) & "#" & sArr(i, 1)
If Not dic.exists(iKey) Then
dic.Add iKey, i
sArr(i, 4) = sArr(i, 1) & "[" & sArr(i, 3) & "]"
arr(0) = arr(0) + 1
arr(1) = arr(1) & sArr(i, 4) & ","
Else
ik = dic.Item(iKey)
sArr(ik, 3) = sArr(i, 3) + sArr(ik, 3)
tmp = sArr(i, 1) & "[" & sArr(ik, 3) & "]"
arr(1) = Replace(arr(1), "," & sArr(ik, 4) & ",", "," & tmp & ",")
sArr(ik, 4) = tmp
End If
dic.Item(iKey2) = arr
Next i
sRow = UBound(aCV)
ReDim Res(1 To sRow, 1 To 2)
For i = 1 To sRow
iKey2 = aCV(i, 1)
If dic.exists(iKey2) Then
arr = dic.Item(iKey2)
Res(i, 1) = arr(0)
Res(i, 2) = Mid(arr(1), 2, Len(arr(1)) - 2)
End If
Next i
Sheets("TK").Range("H2").Resize(sRow, 2) = Res
End SubXin cảm ơn bạn đã giúp đỡ, mình chạy code này thấy khớp với kết quả code của bài 16 rồi.
