Code Lọc và Merge dữ liệu

[ti8pro]

Tôi có bài toán như sau:

Sheet1

stt | nhóm SP | Tên sản phẩm
1 | L1 | 1A
2 | L1 | 1B
3 | L3 | 3A
4 | L2 | 2A
5 | L2 | 2B
6 | L4 | 4A
7 | L1 | 1C
8 | L3 | 3B
9 | L2 | 2C

Giờ tôi muốn lọc toàn bộ và nhóm theo từng loại và copy sang Sheet2 được kết quả như sau

stt | Nhóm SP |Tên sản phẩm
1 | L1 | 1A, 1B, 1C
2 | L2 | 2A, 2B, 2C
3 | L3 | 3A, 3B
4 | L4 |4A

Note: kết quả mỗi nhóm sản phẩm thuộc 1 row, tên các sản phẩm thuộc mỗi loại sản phẩm cũng nằm ở row tương ứng.

Cả nhà giúp hộ nhé.

Special thanks

 

[ndu96081631]

Tôi có bài toán như sau:

Sheet1

stt | nhóm SP | Tên sản phẩm
1 | L1 | 1A
2 | L1 | 1B
3 | L3 | 3A
4 | L2 | 2A
5 | L2 | 2B
6 | L4 | 4A
7 | L1 | 1C
8 | L3 | 3B
9 | L2 | 2C

Giờ tôi muốn lọc toàn bộ và nhóm theo từng loại và copy sang Sheet2 được kết quả như sau

stt | Nhóm SP |Tên sản phẩm
1 | L1 | 1A, 1B, 1C
2 | L2 | 2A, 2B, 2C
3 | L3 | 3A, 3B
4 | L4 |4A

Note: kết quả mỗi nhóm sản phẩm thuộc 1 row, tên các sản phẩm thuộc mỗi loại sản phẩm cũng nằm ở row tương ứng.

Cả nhà giúp hộ nhé.

Special thanks

Dạng bài này trên GPE đã nói nhiều lần rồi... Tuy nhiên, để chắc ăn bạn nên đưa file lên.. tránh tình trạng mô tả 1 đàng mà file thực tế lại khác (mất công làm lại)

 

[ti8pro]

mình attach file yêu cầu cụ thể như sau nhé

thanks

 

[ndu96081631]

mình attach file yêu cầu cụ thể như sau nhé

thanks

Dùng 2 hàm UniqueList và JoinIf (tôi đã từng viết và post lên diễn đàn rồi)

Function UniqueList(Range As Range, Pos As Long) As String
  Dim Clls As Range, Dic
  With CreateObject("Scripting.Dictionary")
    For Each Clls In Range
      If Clls <> "" And Not .Exists(Clls.Value) Then
        .Add Clls.Value, "": Pos = Pos - 1
        If Pos = 0 Then
          UniqueList = Clls: Exit Function
        End If
      End If
    Next Clls
  End With
End Function

Function JoinIf(LValue, LRange As Range, ColIndex As Long, Optional Sep = "") As String
  Dim Clls As Range, Temp(), i As Long
  On Error Resume Next
  If Not IsEmpty(LValue) Then
    For Each Clls In LRange.Resize(, 1)
      If Clls.Value = LValue Then
        ReDim Preserve Temp(i)
        Temp(i) = Clls(, ColIndex)
        i = i + 1
      End If
    Next
    JoinIf = Join(Temp, Sep)
  End If
End Function

Công thức tại C3:

=UniqueList(Data!$C$3:$C$22,ROWS($1:1))

Công thức tại D3

=JoinIf($C3,Data!$C$3:$D$22,2,CHAR(10))

 

[ti8pro]

Cảm ơn ndu96081631

Mình đã thử và chạy công thức chạy ngon với dữ liệu ít. Tuy nhiên, bảng dữ liệu của mình rất lớn, vài nghìn row.

Việc đẩy dữ liệu ra sheet mới được xác định = công thức --> mỗi lần mở/save file, thêm bớt dữ liệu --> Bảng tính lại thực hiện Calculate rất rất lâu.

Bạn giúp mình chỉnh sửa để đẩy ra dữ liệu fix cứng sang sheet 2 nhé. Mỗi lần có thay đổi --> thực hiện Click command Update thì tiện dụng hơn.

Special thanks

 

[ndu96081631]

Cảm ơn ndu96081631

Mình đã thử và chạy công thức chạy ngon với dữ liệu ít. Tuy nhiên, bảng dữ liệu của mình rất lớn, vài nghìn row.

Việc đẩy dữ liệu ra sheet mới được xác định = công thức --> mỗi lần mở/save file, thêm bớt dữ liệu --> Bảng tính lại thực hiện Calculate rất rất lâu.

Bạn giúp mình chỉnh sửa để đẩy ra dữ liệu fix cứng sang sheet 2 nhé. Mỗi lần có thay đổi --> thực hiện Click command Update thì tiện dụng hơn.

Special thanks

Cố gắng nghiên cứu thử xem nào
Thuật toán có sẳn, chỉ sửa Function thành 1 sub thôi mà
Ẹc... Ẹc...

 

[ti8pro]

Cố gắng nghiên cứu thử xem nào
Thuật toán có sẳn, chỉ sửa Function thành 1 sub thôi mà
Ẹc... Ẹc...

Thử cho 2 cái vòng lặp nó chạy "nhanh" cả hơn hò kéo pháo . NEED HELP!

Sheets("Update").Select
    On Error Resume Next
        For j = 1 To Range("Uniquelist").Rows.Count
          If Cells(j + 2, 2) <> "" Then
            For Each Clls In Range("LSP")
                If Clls.Value = Cells(j + 2, 2) Then
                ReDim Preserve Temp(i)
                Temp(i) = Clls(, 14)
                i = i + 1
                End If
                Cells(j + 2, 3) = Join(Temp, vbCrLf)
            Next
           End If
        Next

 

[ndu96081631]

Thử cho 2 cái vòng lặp nó chạy "nhanh" cả hơn hò kéo pháo . NEED HELP!

Sheets("Update").Select
    On Error Resume Next
        For j = 1 To Range("Uniquelist").Rows.Count
          If Cells(j + 2, 2) <> "" Then
            For Each Clls In Range("LSP")
                If Clls.Value = Cells(j + 2, 2) Then
                ReDim Preserve Temp(i)
                Temp(i) = Clls(, 14)
                i = i + 1
                End If
                Cells(j + 2, 3) = Join(Temp, vbCrLf)
            Next
           End If
        Next

Gữi bạn code tham khảo:

Public Arr1
Public Arr2

Sub ConsolText(Src1 As Range, Src2 As Range, Sep As String)
  Dim i As Long, Temp
  With CreateObject("Scripting.Dictionary")
    For i = 1 To Src1.Rows.Count
      If Src1(i, 1) <> "" Then
        Temp = Src1(i, 1).Value
        If Not .Exists(Src1(i, 1).Value) Then
          .Add Src1(i, 1).Value, Src2(i, 1).Value
        Else
          .Item(Temp) = .Item(Temp) & Sep & Src2(i, 1).Value
        End If
      End If
    Next
    Arr1 = .Keys: Arr2 = .Items
  End With
End Sub

Code trên chỉ trích dữ liệu và cho vào 2 biến mảng Arr1, Arr2
Để gán các phần tử Arr1, Arr2 vào cell ta viết thêm 1 code nữa:

Sub Main()
  Set Arr1 = Nothing: Set Arr2 = Nothing
  ConsolText Sheets("Data").Range("C3:C20000"), Sheets("Data").Range("D3:D20000"), Chr(10)
  Range("A2:B60000").ClearContents
  With WorksheetFunction
    Range("A2").Resize(UBound(Arr1) + 1) = .Transpose(Arr1)
    Range("B2").Resize(UBound(Arr1) + 1) = .Transpose(Arr2)
  End With
End Sub

Tôi thử nghiệm với dữ liệu 10000 dòng, chạy cái vèo là xong

 

[ti8pro]

Rất cảm ơn bạn. marco chạy rất tít.

Tuy nhiên thỉnh thoảng bị lỗi. Mình test đi test lại thì thấy nếu 1 Cell (sau khi merge) chứa nhiều ký tự quá thì bị lỗi thì phải.

Mình có thử tìm hiểu 1 cell có thể chứa bao nhiêu ký tự nhưng thấy từ excel 97 trở đi, một cell có thể chứa 32000 ký tự.

Vậy lỗi này cần xử lý thế nào?

Bạn xem và cố giúp mình nốt nhé.

Chân thành cảm ơn

 

[ndu96081631]

Rất cảm ơn bạn. marco chạy rất tít.

Tuy nhiên thỉnh thoảng bị lỗi. Mình test đi test lại thì thấy nếu 1 Cell (sau khi merge) chứa nhiều ký tự quá thì bị lỗi thì phải.

Mình có thử tìm hiểu 1 cell có thể chứa bao nhiêu ký tự nhưng thấy từ excel 97 trở đi, một cell có thể chứa 32000 ký tự.

Vậy lỗi này cần xử lý thế nào?

Bạn xem và cố giúp mình nốt nhé.

Chân thành cảm ơn

Tôi đoán lỗi ở hàm TRANSPOST
Vậy tạm thời sửa code lại thế này:

Function ConsolText(Src1 As Range, Src2 As Range, Sep As String)
  Dim i As Long, j As Long, Temp, Arr(60000, 1), elm
  With CreateObject("Scripting.Dictionary")
    For i = 1 To Src1.Rows.Count
      If Src1(i, 1) <> "" Then
        Temp = Src1(i, 1).Value
        If Not .Exists(Src1(i, 1).Value) Then
          .Add Src1(i, 1).Value, Src2(i, 1).Value
        ElseIf Src2(i, 1) <> "" Then
          .Item(Temp) = .Item(Temp) & Sep & Src2(i, 1).Value
        End If
      End If
    Next
    For Each elm In .Keys
      Arr(j, 0) = elm
      Arr(j, 1) = .Item(elm)
      j = j + 1
    Next
    ConsolText = Arr
  End With
End Function

Sub Main()
  Dim Arr
  Arr = ConsolText(Sheets("Data").Range("C3:C20000"), Sheets("Data").Range("D3:D20000"), Chr(10))
  Range("A2:B60000").ClearContents
  Range("A3:B3").Resize(UBound(Arr, 1) + 1) = Arr
End Sub

Chưa hay lắm nhưng cũng chưa nghĩ ra được giải pháp nào có thể bỏ bớt vòng lập

 

[ti8pro]

Chót chét

có làm thêm được:

1. Chỉ merge các giá trị Unique
2. Cho phép cùng với điều kiện loại sản phẩm --> có thể cùng với 1 lần thực hiện merge với 2 hay nhiều range không? (giống code trước tạo 2 arr1, arr2)

special thanks

 

[ndu96081631]

Chót chét

có làm thêm được:

1. Chỉ merge các giá trị Unique
2. Cho phép cùng với điều kiện loại sản phẩm --> có thể cùng với 1 lần thực hiện merge với 2 hay nhiều range không? (giống code trước tạo 2 arr1, arr2)

special thanks

Chưa hiểu lắm!
Bạn đưa thử file vài chục dòng lên đây xem ---> Nhớ làm luôn kết quả minh họa nhé

 

[ti8pro]

mình gửi file nhé

 

[ndu96081631]

mình gửi file nhé

Bài này.. khoai thật
Tạm dùng code này:

Function ConsolText(Src1 As Range, Src2 As Range, Src3 As Range, Sep As String)
  Dim i As Long, j As Long, Arr(60000, 2)
  Dim Tmp1 As String, Tmp2 As String, Tmp3 As String
  With CreateObject("Scripting.Dictionary")
    For i = 1 To Src1.Rows.Count
      If Src1(i, 1) <> "" Then
        Tmp1 = Src1(i, 1).Value
        If Not .Exists(Tmp1) Then
          .Add Tmp1, j
          Arr(j, 0) = Tmp1
          If Src2(i, 1) <> "" Then Arr(j, 1) = Src2(i, 1)
          If Src3(i, 1) <> "" Then Arr(j, 2) = Src3(i, 1)
          j = j + 1
        Else
          If Src2(i, 1) <> "" Then
            Tmp2 = Src2(i, 1).Value
            If InStr(Arr(.Item(Tmp1), 1), Tmp2) = 0 Then
              Arr(.Item(Tmp1), 1) = IIf(Arr(.Item(Tmp1), 1) = "", Tmp2, Arr(.Item(Tmp1), 1) & Sep & Tmp2)
            End If
          End If
          If Src3(i, 1) <> "" Then
            Tmp3 = Src3(i, 1).Value
            If InStr(Arr(.Item(Tmp1), 2), Tmp3) = 0 Then
              Arr(.Item(Tmp1), 2) = IIf(Arr(.Item(Tmp1), 2) = "", Tmp3, Arr(.Item(Tmp1), 2) & Sep & Tmp3)
            End If
          End If
        End If
      End If
    Next
  End With
  ConsolText = Arr
End Function

Sub Main()
  Dim Arr, Src1 As Range, Src2 As Range, Src3 As Range
  Set Src1 = Sheets("Data").Range("C3:C20000")
  Set Src2 = Sheets("Data").Range("D3:D20000")
  Set Src3 = Sheets("Data").Range("E3:E20000")
  Arr = ConsolText(Src1, Src2, Src3, Chr(10))
  Range("A3:C60000").ClearContents
  Range("A3:C3").Resize(UBound(Arr, 1) + 1) = Arr
End Sub

Vì trong code có dùng InStr để so sánh nên vẫn tiềm ẩn rủi ro ---> Bạn cứ test xem thế nào nhé