Nối chuỗi theo nhiều điều kiện

[huongmai]

Chào cả nhà,
Em phải làm một bảng thống kê: Liệt kê các máy theo bộ phận, theo Mã PM sử dụng như ví dụ file đính kèm ạ.
Hiện tại là làm thủ công nên mất thời gian + sai sót cũng nhiều.
Em tìm đến các hàm nối chuỗi nhưng cũng loay hoay mãi mà chưa áp dụng làm sao cho đúng cả.
Em post lên đây, nhờ các bác trợ giúp.
Cảm ơn cả nhà nhiều ạ.
Hương

 

[quanluu]

Chào cả nhà,
Em phải làm một bảng thống kê: Liệt kê các máy theo bộ phận, theo Mã PM sử dụng như ví dụ file đính kèm ạ.
Hiện tại là làm thủ công nên mất thời gian + sai sót cũng nhiều.
Em tìm đến các hàm nối chuỗi nhưng cũng loay hoay mãi mà chưa áp dụng làm sao cho đúng cả.
Em post lên đây, nhờ các bác trợ giúp.
Cảm ơn cả nhà nhiều ạ.
Hương

Bạn dùng code dài này vậy

Sub Macro1()
Dim i, j, k As Integer, arr(), bp1, bp2 As String
Application.DisplayAlerts = False
'SORT
    ActiveWorkbook.Worksheets("Chitiet").ListObjects("Table_Query_from_Thietbi"). _
        Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Chitiet").ListObjects("Table_Query_from_Thietbi"). _
        Sort.SortFields.Add Key:=Range("Table_Query_from_Thietbi[MaPM]"), SortOn:= _
        xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Chitiet").ListObjects("Table_Query_from_Thietbi"). _
        Sort.SortFields.Add Key:=Range("Table_Query_from_Thietbi[Bophan]"), SortOn _
        :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Chitiet").ListObjects( _
        "Table_Query_from_Thietbi").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ' Do
    With Sheets("Chitiet")
        lr = .Range("A65000").End(3).Row
        ReDim arr(1 To lr, 1 To 4)
        For i = 2 To lr
            bp1 = .Cells(i, 2) & .Cells(i, 3)
            k = k + 1
            arr(k, 1) = .Cells(i, 3)
            arr(k, 2) = .Cells(i, 2)
            For j = i To lr + 1
                bp2 = .Cells(j, 2) & .Cells(j, 3)
                If bp1 = bp2 Then
                    arr(k, 3) = arr(k, 3) & "," & .Cells(j, 1)
                    dem = dem + 1
                Else
                    arr(k, 4) = dem
                    arr(k, 3) = Right(arr(k, 3), Len(arr(k, 3)) - 1)
                    dem = 0
                    i = j - 1
                    GoTo 1
                End If
            Next
1:
        Next
    End With
    Range("K1").Resize(k, 4) = arr
    
    ' Merge
    lr = Range("K65000").End(3).Row
    For i = 1 To lr
        For j = i To lr + 1
            If Range("K" & j) <> Range("K" & i) Then
                Range("K" & i & ":K" & j - 1).Merge
                i = j - 1
                GoTo 2
            End If
        Next
2:
    Next
    Range("K1:N" & lr).Borders.LineStyle = xlContinuous
    Application.DisplayAlerts = True
End Sub

 

[huongmai]

Bạn giúp mình làm vào file được không?
Mình thử rồi mà vẫn không làm được bạn ạ.
Cảm ơn bạn nhiều.

 

[giangleloi]

Bạn giúp mình làm vào file được không?
Mình thử rồi mà vẫn không làm được bạn ạ.
Cảm ơn bạn nhiều.

Bấm vô hình trong file để chạy code nhé:

Sub GPE()
Application.DisplayAlerts = False
Dim Dic As Object, Arr(), vlArr(), I As Long, J As Long, K As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Chitiet")
  Arr = .Range(.[A2], .[A65000].End(3)).Resize(, 3).Value
End With
   ReDim vlArr(1 To UBound(Arr, 1), 1 To 4)
   For I = 1 To UBound(Arr, 1)
    Tem = Arr(I, 3) & "#" & Arr(I, 2)
     If Not Dic.exists(Tem) Then
       K = K + 1
       Dic.Add Tem, K
       vlArr(K, 1) = Arr(I, 3)
       vlArr(K, 2) = Arr(I, 2)
       vlArr(K, 3) = Arr(I, 1)
       vlArr(K, 4) = 1
      Else
       vlArr(Dic.Item(Tem), 3) = vlArr(Dic.Item(Tem), 3) & ", " & Arr(I, 1)
       vlArr(Dic.Item(Tem), 4) = vlArr(Dic.Item(Tem), 4) + 1
     End If
  Next
With Sheets("Tonghop")
 .[A2:C10000].Clear
 .[A2].Resize(K, 4) = vlArr
 .[A2].Resize(K, 4).Sort .[A2].Resize(K, 2), xlAscending
 .[A2].Resize(K, 4).Borders.LineStyle = 1
 For I = 2 To K + 1
        For J = I To K + 2
            If .Range("A" & J) <> .Range("A" & I) Then
                .Range("A" & I & ":A" & J - 1).Merge
                .Range("A" & I & ":A" & J - 1).HorizontalAlignment = xlCenter
                .Range("A" & I & ":A" & J - 1).VerticalAlignment = xlCenter
                I = J - 1
                GoTo GPE1
            End If
        Next
GPE1:
    Next
End With
Set Dic = Nothing
Application.DisplayAlerts = True
End Sub

 

[quanluu]

Bạn giúp mình làm vào file được không?
Mình thử rồi mà vẫn không làm được bạn ạ.
Cảm ơn bạn nhiều.

Bạn click vào shape RUN

 

[giangleloi]

Bạn click vào shape RUN

Code trong file chạy thiếu 2 kết quả. Không biết có phải mình hoa mắt không. Mong bạn thông cảm.

 

[quanluu]

Code trong file chạy thiếu 2 kết quả. Không biết có phải mình hoa mắt không. Mong bạn thông cảm.

Cảm ơn bạn. Mình đã fix lại rùi.

 

[huongmai]

Bấm vô hình trong file để chạy code nhé:

Rất chính xác
Cảm ơn bạn nhiều nhé

 

[giangleloi]

Rất chính xác
Cảm ơn bạn nhiều nhé

Hôm qua mình không để ý giờ nhìn lại mới thấy. Đoạn này bạn sửa C thành D mới hợp lý. .[A2:C10000].Clear cho những lần chạy code tiếp theo nếu dữ liệu ít hơn.

 

[doveandrose]

===========================================
bài viết thừa . Nhờ Mod xóa vậy

 

[huongmai]

Hôm qua mình không để ý giờ nhìn lại mới thấy. Đoạn này bạn sửa C thành D mới hợp lý. .[A2:C10000].Clear cho những lần chạy code tiếp theo nếu dữ liệu ít hơn.

Hi, chào bạn.
Mình vừa mới thêm dữ liệu và cũng phát hiện ra chỗ này --> fix lại rồi.
Cám ơn bạn rất nhiều.