Viết Code VBA để tổng hợp và lọc trùng dữ liệu

Phạm Trung Tùng Lâm · 26/5/22

Dear all

Em có file tổng hợp như đính kèm. Em muốn tổng hợp tên người "Phụ trách" từ Sheet "DATA" vào Sheet "TONG HOP" dựa trên dữ liệu "Code". Do có nhiều Code trùng người "Phụ trách" nên tổng hợp bằng CONCAT thì tên người phụ trách sẽ bị lặp lại nhiều lần.
Vì vậy em muốn nhờ các bác viết giúp em 1 đoạn Code để có thể tổng hợp vào cột "Phụ trách" ở Sheet "TONG HOP".

Em xin cảm ơn

Quang_Hải · 26/5/22

Thử cod này coi sao

Mã:

Sub abc()
Dim Dic1 As Object, Dic2 As Object, sArr(), i As Long, tmp As String, dArr(), k As Long, tmp2 As String
Set Dic1 = CreateObject("scripting.dictionary")
Set Dic2 = CreateObject("scripting.dictionary")
With Sheets("Data")
   sArr = .Range("D3", .Range("D65536").End(3)).Resize(, 4).Value
End With
ReDim dArr(1 To UBound(sArr), 1 To 2)
For i = 1 To UBound(sArr)
   tmp = Replace(UCase(sArr(i, 1)), " ", "")
   tmp2 = sArr(i, 1) & sArr(i, 3)
   If Not Dic1.exists(tmp) Then
      k = k + 1
      Dic1.Add tmp, k
      Dic2.Add tmp2, Empty
      dArr(k, 1) = sArr(i, 1)
      dArr(k, 2) = sArr(i, 3)
   Else
      If Not Dic2.exists(tmp2) Then
         dArr(Dic1.Item(tmp), 2) = dArr(Dic1.Item(tmp), 2) & "," & sArr(i, 3)
      End If
   End If
Next
Sheets("Tong hop").Range("F4").Resize(k, 2) = dArr
End Sub

befaint · 26/5/22

Quang_Hải đã viết:
Set Dic1 = CreateObject("scripting.dictionary")
Set Dic2 = CreateObject("scripting.dictionary")

Thấy lần trước anh viết là thành thạo sử dụng Dictionary.

Anh cho em hỏi:
Thay vì viết:

PHP:

Set Dic1 = CreateObject("scripting.dictionary")
Set Dic2 = CreateObject("scripting.dictionary")

thì ta có thể viết như thế này được không?

PHP:

Set Dic1 = CreateObject("scripting.dictionary")
Set Dic2 = Dic1

------
Bài này dùng 1 Dictionary object cũng được.

BuiQuangThuan · 26/5/22

befaint đã viết:
thì ta có thể viết như thế này được không?

Hihi. Thấy câu hỏi của anh hay quá. em cũng thắc mắc như này

snow25 · 26/5/22

Phạm Trung Tùng Lâm đã viết:
Dear all

Em có file tổng hợp như đính kèm. Em muốn tổng hợp tên người "Phụ trách" từ Sheet "DATA" vào Sheet "TONG HOP" dựa trên dữ liệu "Code". Do có nhiều Code trùng người "Phụ trách" nên tổng hợp bằng CONCAT thì tên người phụ trách sẽ bị lặp lại nhiều lần.
Vì vậy em muốn nhờ các bác viết giúp em 1 đoạn Code để có thể tổng hợp vào cột "Phụ trách" ở Sheet "TONG HOP".

Em xin cảm ơn

View attachment 276462

Thử code.

Mã:

Sub abc()
   Dim i As Long, lr As Long, dic As Object, arr, kq, a As Long, s As String, dk As String
   Set dic = CreateObject("scripting.dictionary")
   With Sheets("Data")
        lr = .Range("D" & Rows.Count).End(xlUp).Row
        arr = .Range("D3:F" & lr).Value
        ReDim kq(1 To UBound(arr), 1 To 3)
        For i = 1 To UBound(arr)
            dk = arr(i, 1)
            If Not dic.exists(dk) Then
               a = a + 1
               dic.Add dk, a
               kq(a, 1) = dk
               kq(a, 3) = arr(i, 3)
           Else
               s = "," & kq(dic.Item(dk), 3) & ","
               If InStr(s, "," & arr(i, 3) & ",") = 0 Then
                  kq(dic.Item(dk), 3) = kq(dic.Item(dk), 3) & "," & arr(i, 3)
               End If
          End If
     Next i
  End With
  With Sheets("tong hop")
       .Range("H4:J1000").ClearContents
       .Range("H4:J4").Resize(a).Value = kq
  End With
  Set dic = Nothing

End Sub

Phạm Trung Tùng Lâm · 26/5/22

snow25 đã viết:

Thử code.

Mã:

Sub abc()
   Dim i As Long, lr As Long, dic As Object, arr, kq, a As Long, s As String, dk As String
   Set dic = CreateObject("scripting.dictionary")
   With Sheets("Data")
        lr = .Range("D" & Rows.Count).End(xlUp).Row
        arr = .Range("D3:F" & lr).Value
        ReDim kq(1 To UBound(arr), 1 To 3)
        For i = 1 To UBound(arr)
            dk = arr(i, 1)
            If Not dic.exists(dk) Then
               a = a + 1
               dic.Add dk, a
               kq(a, 1) = dk
               kq(a, 3) = arr(i, 3)
           Else
               s = "," & kq(dic.Item(dk), 3) & ","
               If InStr(s, "," & arr(i, 3) & ",") = 0 Then
                  kq(dic.Item(dk), 3) = kq(dic.Item(dk), 3) & "," & arr(i, 3)
               End If
          End If
     Next i
  End With
  With Sheets("tong hop")
       .Range("H4:J1000").ClearContents
       .Range("H4:J4").Resize(a).Value = kq
  End With
  Set dic = Nothing

End Sub

Em cảm ơn ạ
Bác có thể sửa giúp em 1 tý được k ạ, em chỉ muốn chạy ra dữ liệu "Phụ trách" thôi ạ. Bên cột "Code" có những mã nào thì cột "Phụ trách" sẽ tổng hợp ra tên người phụ trách tương ứng ạ ( Giống kiểu Lookup ấy ạ, nhưng Pro hơn nhiều

)

HieuCD · 26/5/22

Phạm Trung Tùng Lâm đã viết:
Em có file tổng hợp như đính kèm. Em muốn tổng hợp tên người "Phụ trách" từ Sheet "DATA" vào Sheet "TONG HOP" dựa trên dữ liệu "Code". Do có nhiều Code trùng người "Phụ trách" nên tổng hợp bằng CONCAT thì tên người phụ trách sẽ bị lặp lại nhiều lần.
Vì vậy em muốn nhờ các bác viết giúp em 1 đoạn Code để có thể tổng hợp vào cột "Phụ trách" ở Sheet "TONG HOP".
Em xin cảm ơn

Dữ liệu code đã có và dữ liệu không nhiều nên không cần dùng dic

Mã:

Sub ABC()
  Dim arr(), aCode(), res(), code$, i&, r&
 
  With Sheets("Data")
    arr = .Range("D3", .Range("F" & Rows.Count).End(xlUp)).Value
  End With
  With Sheets("tong hop")
    aCode = .Range("B4", .Range("B" & Rows.Count).End(xlUp)).Value
    ReDim res(1 To UBound(aCode), 1 To 1)
    For i = 1 To UBound(aCode)
      code = aCode(i, 1)
      For r = 1 To UBound(arr)
        If arr(r, 1) = code Then
          If res(i, 1) = Empty Then
            res(i, 1) = arr(r, 3)
          ElseIf InStr(1, "," & res(i, 1) & ",", "," & arr(r, 3) & ",") = 0 Then
            res(i, 1) = res(i, 1) & "," & arr(r, 3)
          End If
        End If
      Next r
    Next i
    .Range("E4").Resize(UBound(aCode)).Value = res
  End With
End Sub

Nếu vùng code chưa có, không dùng dic cũng ổn

Mã:

Sub ABC2()
  Dim arr(), aCode(), res(), code$, sRow&, i&, r&, k&
 
  With Sheets("Data")
    arr = .Range("D3", .Range("F" & Rows.Count).End(xlUp)).Value
  End With
  sRow = UBound(arr)
  ReDim res(1 To sRow, 1 To 2)
  For i = 1 To sRow
    code = arr(i, 1)
    For r = 1 To k
      If res(r, 1) = code Then Exit For
    Next r
    If r > k Then k = r
    If res(r, 1) = Empty Then res(r, 1) = code
    If res(r, 2) = Empty Then
      res(r, 2) = arr(i, 3)
    ElseIf InStr(1, "," & res(r, 2) & ",", "," & arr(i, 3) & ",") = 0 Then
      res(r, 2) = res(r, 2) & "," & arr(i, 3)
    End If
  Next i
 
  With Sheets("tong hop")
    .Range("F4").Resize(k, 2).Value = res
  End With
End Sub

Nếu thích dùng dic

Mã:

Sub ABC3()
  Dim arr(), res(), dic As Object, key$, sRow&, i&, k&, ik&
 
  Set dic = CreateObject("scripting.dictionary")
  With Sheets("Data")
    arr = .Range("D3", .Range("F" & Rows.Count).End(xlUp)).Value
  End With
  sRow = UBound(arr)
  ReDim res(1 To sRow, 1 To 2)
  For i = 1 To sRow
    key = arr(i, 1) & "|" & arr(i, 3)
    If Not dic.exists(arr(i, 1)) Then
      k = k + 1
      dic.Add arr(i, 1), k
      res(k, 1) = arr(i, 1)
      res(k, 2) = arr(i, 3)
      dic.Add key, ""
    ElseIf Not dic.exists(key) Then
      ik = dic.Item(arr(i, 1))
      res(ik, 2) = res(ik, 2) & "," & arr(i, 3)
      dic.Add key, ""
    End If
  Next i
 
  With Sheets("tong hop")
    .Range("F4:G1000").ClearContents
    .Range("F4").Resize(k, 2).Value = res
  End With
  Set dic = Nothing
End Sub

befaint · 26/5/22

Phạm Trung Tùng Lâm đã viết:
Giống kiểu Lookup ấy ạ, nhưng Pro hơn nhiều

E x c e l 2021/ 365

VetMini · 26/5/22

befaint đã viết:
------
Bài này dùng 1 Dictionary object cũng được.

Nếu 2 cái không chia sẻ dữ liệu thì không nên dùng chung.

befaint đã viết:
E x c e l 2021/ 365
...

Mà dạo này hết dị ứng với đía-ồn và vắt tiết rồi hả

befaint · 26/5/22

VetMini đã viết:
Mà dạo này hết dị ứng với đía-ồn và vắt tiết rồi hả

Lúc đầu, em xem bài đăng rồi lại bỏ qua.

Có bài #2 em mới vào trao đổi.

Phạm Trung Tùng Lâm · 26/5/22

HieuCD đã viết:

Dữ liệu code đã có và dữ liệu không nhiều nên không cần dùng dic

Mã:

Sub ABC()
  Dim arr(), aCode(), res(), code$, i&, r&
 
  With Sheets("Data")
    arr = .Range("D3", .Range("F" & Rows.Count).End(xlUp)).Value
  End With
  With Sheets("tong hop")
    aCode = .Range("B4", .Range("B" & Rows.Count).End(xlUp)).Value
    ReDim res(1 To UBound(aCode), 1 To 1)
    For i = 1 To UBound(aCode)
      code = aCode(i, 1)
      For r = 1 To UBound(arr)
        If arr(r, 1) = code Then
          If res(i, 1) = Empty Then
            res(i, 1) = arr(r, 3)
          ElseIf InStr(1, "," & res(i, 1) & ",", "," & arr(r, 3) & ",") = 0 Then
            res(i, 1) = res(i, 1) & "," & arr(r, 3)
          End If
        End If
      Next r
    Next i
    .Range("E4").Resize(UBound(aCode)).Value = res
  End With
End Sub

Nếu vùng code chưa có, không dùng dic cũng ổn

Mã:

Sub ABC2()
  Dim arr(), aCode(), res(), code$, sRow&, i&, r&, k&
 
  With Sheets("Data")
    arr = .Range("D3", .Range("F" & Rows.Count).End(xlUp)).Value
  End With
  sRow = UBound(arr)
  ReDim res(1 To sRow, 1 To 2)
  For i = 1 To sRow
    code = arr(i, 1)
    For r = 1 To k
      If res(r, 1) = code Then Exit For
    Next r
    If r > k Then k = r
    If res(r, 1) = Empty Then res(r, 1) = code
    If res(r, 2) = Empty Then
      res(r, 2) = arr(i, 3)
    ElseIf InStr(1, "," & res(r, 2) & ",", "," & arr(i, 3) & ",") = 0 Then
      res(r, 2) = res(r, 2) & "," & arr(i, 3)
    End If
  Next i
 
  With Sheets("tong hop")
    .Range("F4").Resize(k, 2).Value = res
  End With
End Sub

Nếu thích dùng dic

Mã:

Sub ABC3()
  Dim arr(), res(), dic As Object, key$, sRow&, i&, k&, ik&
 
  Set dic = CreateObject("scripting.dictionary")
  With Sheets("Data")
    arr = .Range("D3", .Range("F" & Rows.Count).End(xlUp)).Value
  End With
  sRow = UBound(arr)
  ReDim res(1 To sRow, 1 To 2)
  For i = 1 To sRow
    key = arr(i, 1) & "|" & arr(i, 3)
    If Not dic.exists(arr(i, 1)) Then
      k = k + 1
      dic.Add arr(i, 1), k
      res(k, 1) = arr(i, 1)
      res(k, 2) = arr(i, 3)
      dic.Add key, ""
    ElseIf Not dic.exists(key) Then
      ik = dic.Item(arr(i, 1))
      res(ik, 2) = res(ik, 2) & "," & arr(i, 3)
      dic.Add key, ""
    End If
  Next i
 
  With Sheets("tong hop")
    .Range("F4:G1000").ClearContents
    .Range("F4").Resize(k, 2).Value = res
  End With
  Set dic = Nothing
End Sub

Em cảm ơn ạ. Bác có thể viết hộ em thêm 1 đoạn code để mỗi lần cập nhật dữ liệu mới ấy ạ, nó sẽ xóa toàn bộ dữ liệu cũ trước. Em cảm ơn ạ

namvu230397 · 26/5/22

Phạm Trung Tùng Lâm đã viết:
Em cảm ơn ạ. Bác có thể viết hộ em thêm 1 đoạn code để mỗi lần cập nhật dữ liệu mới ấy ạ, nó sẽ xóa toàn bộ dữ liệu cũ trước. Em cảm ơn ạ

Trong đoạn code thứ 3 có chức năng đó rồi bạn, mỗi lần cập nhật sẽ xoá hết nội dung vùng F4:G1000 và ghi dữ liệu mới. Chính là dòng .Range("F4:G1000").clearcontents

HieuCD · 26/5/22

Phạm Trung Tùng Lâm đã viết:
Em cảm ơn ạ. Bác có thể viết hộ em thêm 1 đoạn code để mỗi lần cập nhật dữ liệu mới ấy ạ, nó sẽ xóa toàn bộ dữ liệu cũ trước. Em cảm ơn ạ

"xóa toàn bộ dữ liệu cũ trước" cụ thể là gì? xóa kết quả trước hay xóa dữ liệu cột B sheet tổng hợp?

Viết Code VBA để tổng hợp và lọc trùng dữ liệu

Phạm Trung Tùng Lâm

Thành viên mới

File đính kèm

Quang_Hải

Thành viên gạo cội

befaint

|||||||||||||

BuiQuangThuan

❆❆❆❆❆❆❆❆❆❆❆❆

snow25

Thành viên gạo cội

Phạm Trung Tùng Lâm

Thành viên mới

HieuCD

Chuyên gia GPE

befaint

|||||||||||||

VetMini

Ăn cùng góc phố

befaint

|||||||||||||

Phạm Trung Tùng Lâm

Thành viên mới

namvu230397

Thành viên hoạt động

HieuCD

Chuyên gia GPE

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian