Nhờ ghép dữ liệu các dòng có cùng tiền tố thành 1 dòng. (1 người xem)

[MinhKhai]

Chào các anh chị.
Em có dữ liệu như file đính kèm và muốn chuyển mỗi 6 dòng (tối đa) có tiền tố giống nhau thành 1 dòng với điều kiện được nêu trong file. Nhờ các anh chị giúp đỡ (hàm hoặc VBA đều được)
Ngoài ra em có học mót từ diễn đàn này đoạn code để áp dụng lọc có sắp xếp dữ liệu. Tuy nhiên với những dữ liệu có tiêu đề cột (Column Header) là tiếng Việt thì chưa biết cách xử lý nên tạm thời thêm dòng phụ. Nhờ các anh sửa lại code để không phải dùng cột phụ.
Chân thành cảm ơn các anh chị !

 

[HUONGHCKT]

Chào các anh chị.
Em có dữ liệu như file đính kèm và muốn chuyển mỗi 6 dòng (tối đa) có tiền tố giống nhau thành 1 dòng với điều kiện được nêu trong file. Nhờ các anh chị giúp đỡ (hàm hoặc VBA đều được)
Ngoài ra em có học mót từ diễn đàn này đoạn code để áp dụng lọc có sắp xếp dữ liệu. Tuy nhiên với những dữ liệu có tiêu đề cột (Column Header) là tiếng Việt thì chưa biết cách xử lý nên tạm thời thêm dòng phụ. Nhờ các anh sửa lại code để không phải dùng cột phụ.
Chân thành cảm ơn các anh chị !

Trong khi chờ các giải pháp khác.
Hãy thử code sau (cho yêu cầu 1)

Option Explicit

Sub Loc_Ghep()
Dim i&, j&, t&, k&, Lr&
Dim Arr(), KQ(), S, Tam
Dim Dic As Object, Key
Dim Sh As Worksheet
Set Sh = Sheets("TonKho")
Lr = Sh.Cells(10000, 2).End(3).Row
Arr = Sh.Range("B3:D" & Lr).Value
ReDim KQ(1 To UBound(Arr), 1 To 1)
Set Dic = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(Arr)
    Key = Arr(i, 1)
        If Not Dic.Exists(Key) Then
            Dic(Key) = i
        Else
            Dic(Key) = Dic(Key) & "|" & i
    End If
Next i
For Each Key In Dic.Keys
    S = Split(Dic(Key), "|"): Tam = Empty
        For j = LBound(S) To UBound(S)
            If j Mod 6 = 0 Then k = k + 1: Tam = Empty: t = 1
                Tam = Tam & Arr(S(j), 2) & Arr(S(j), 3) & "/ "
            If j Mod 6 <> 0 Then t = t + 1
                KQ(k, 1) = Key & ". " & Tam & "T" & t
        Next j
Next Key
If k Then
Sh.Range("N22").Resize(10000, 1).ClearContents
Sh.Range("N22").Resize(k, 1) = KQ
End If
Set Dic = Nothing
End Sub

Tôi chưa test kỹ, nhưng nhìn qua cũng giống với kết quả làm tay của bạn.
bạn test lại nhé.

 

[tranhungdao12a3]

Bạn set index số dòng cần ghép cho cột STT, rồi viết một hàm Dax sau là được:
Ghép:=CONCATENATEX('Table1','Table1'[MÃ SP],"/")&"/T"&count('Table1'[STT])

 

[Nhattanktnn]

Em có dữ liệu như file đính kèm và muốn chuyển mỗi 6 dòng (tối đa) có tiền tố giống nhau thành 1 dòng với điều kiện được nêu trong file. Nhờ các anh chị giúp đỡ (hàm hoặc VBA đều được)

Thử code sau:

Sub GhepChuoi()
Dim a(), b(), i&, n&, k&
With Sheets("TonKho")
    a = .Range("B2:D" & .Cells(Rows.Count, "B").End(xlUp).Row + 1).Value
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 2 To UBound(a)
        If a(i, 1) <> a(i - 1, 1) Or n = 5 Then
            If k Then b(k, 1) = b(k, 1) & "/ T" & n + 1
            k = k + 1:           n = 0
        Else
            n = n + 1
        End If
        b(k, 1) = IIf(n = 0, a(i, 1) & ". ", b(k, 1) & "/ ") & a(i, 2) & a(i, 3)
    Next
    .Range("W22").Resize(10000, 1).ClearContents
    .Range("W22").Resize(k - 1, 1) = b
End With
End Sub

Nhờ các anh sửa lại code để không phải dùng cột phụ

Sửa câu truy vấn:

Query = "SELECT F2,F3,F4,F5,F6,F7,CDATE(F8),F9,F12 FROM [ALL$A3:L] WHERE F10 IS NULL ORDER BY F2, F3, F5 "

Và sửa connection string:

"Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=No;"";"

 

[MinhKhai]

Trong khi chờ các giải pháp khác.
Hãy thử code sau (cho yêu cầu 1)

Option Explicit

Sub Loc_Ghep()
Dim i&, j&, t&, k&, Lr&
Dim Arr(), KQ(), S, Tam
Dim Dic As Object, Key
Dim Sh As Worksheet
Set Sh = Sheets("TonKho")
Lr = Sh.Cells(10000, 2).End(3).Row
Arr = Sh.Range("B3:D" & Lr).Value
ReDim KQ(1 To UBound(Arr), 1 To 1)
Set Dic = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(Arr)
    Key = Arr(i, 1)
        If Not Dic.Exists(Key) Then
            Dic(Key) = i
        Else
            Dic(Key) = Dic(Key) & "|" & i
    End If
Next i
For Each Key In Dic.Keys
    S = Split(Dic(Key), "|"): Tam = Empty
        For j = LBound(S) To UBound(S)
            If j Mod 6 = 0 Then k = k + 1: Tam = Empty: t = 1
                Tam = Tam & Arr(S(j), 2) & Arr(S(j), 3) & "/ "
            If j Mod 6 <> 0 Then t = t + 1
                KQ(k, 1) = Key & ". " & Tam & "T" & t
        Next j
Next Key
If k Then
Sh.Range("N22").Resize(10000, 1).ClearContents
Sh.Range("N22").Resize(k, 1) = KQ
End If
Set Dic = Nothing
End Sub

Tôi chưa test kỹ, nhưng nhìn qua cũng giống với kết quả làm tay của bạn.
bạn test lại nhé.

Cảm ơn bạn rất nhiều. Mình Test đã đúng như yêu cầu rồi nhé

Bài đã được tự động gộp: 7/9/23

Thử code sau:

Sub GhepChuoi()
Dim a(), b(), i&, n&, k&
With Sheets("TonKho")
    a = .Range("B2:D" & .Cells(Rows.Count, "B").End(xlUp).Row + 1).Value
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 2 To UBound(a)
        If a(i, 1) <> a(i - 1, 1) Or n = 5 Then
            If k Then b(k, 1) = b(k, 1) & "/ T" & n + 1
            k = k + 1:           n = 0
        Else
            n = n + 1
        End If
        b(k, 1) = IIf(n = 0, a(i, 1) & ". ", b(k, 1) & "/ ") & a(i, 2) & a(i, 3)
    Next
    .Range("W22").Resize(10000, 1).ClearContents
    .Range("W22").Resize(k - 1, 1) = b
End With
End Sub

Sửa câu truy vấn:

Query = "SELECT F2,F3,F4,F5,F6,F7,CDATE(F8),F9,F12 FROM [ALL$A3:L] WHERE F10 IS NULL ORDER BY F2, F3, F5 "

Và sửa connection string:

"Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=No;"";"

Code ngắn mà hoạt động đã đúng yêu cầu của em. Cái Connection String và câu truy vấn cũng đã xử lý được vấn đề của em. Chân thành cảm ơn bác nhé.

 

[HUONGHCKT]

Cảm ơn bạn rất nhiều. Mình Test đã đúng như yêu cầu rồi nhé

Bài đã được tự động gộp: 7/9/23

Code ngắn mà hoạt động đã đúng yêu cầu của em. Cái Connection String và câu truy vấn cũng đã xử lý được vấn đề của em. Chân thành cảm ơn bác nhé.

Bạn thử thêm 1 dòng nào đó đã có ở trên vào dòng cuối cùng và chạy 2 code xem kết quả có khác nhay không?
Thân.

 

[hocexcel_1991]

Excel 365

=LET(s,B2:B349,e,TEXTAFTER(E2:E349,"-"),REDUCE("Ket qua mong muon",UNIQUE(s),LAMBDA(x,y,VSTACK(x,BYROW(WRAPROWS(FILTER(e,y=s),6,""),LAMBDA(b,y&". "&TEXTJOIN("/",,b)&"/T"&SUM(N(b<>""))))))))

 

[Nhattanktnn]

Bạn thử thêm 1 dòng nào đó đã có ở trên vào dòng cuối cùng và chạy 2 code xem kết quả có khác nhay không?
Thân.

Bài này họ dùng ADO để lấy dữ liệu sang, sau đó code mới xử lý dữ liệu đó. Mà dữ liệu dùng ADO đưa sang thì câu truy vấn đã order by các cột đó rồi, nên không thể có chuyện nằm xa nhau đâu bác ạ