Gộp text ở nhiều Cell vào 1 Cell theo điều kiện

[khocthet296]

Loay hoay mãi không làm đc nên lên đây nhờ các thầy làm giúp,
em đang có 1 bảng khoảng tầm 20k dòng, cần gộp các text ở nhiều cell vào 1 cell để theo dõi, nếu làm thủ công xong chắc em cũng teo mất 10kg thịt
điều kiện :
1, lọc theo giá trị ở cột A, và gộp giá trị các cell ở côt A giống nhau vào 1 Cell.
ví dụ : A1 = 334455, B1 = abc
A2 = 334455, B2 = def
A3 = 334455, B3 = ghi

dữ liệu xuất ra = abc / def / ghi
2, nâng cao hơn 1 ít là
như ví dụ ở trên thì A1,A2,A3 giống nhau, vậy làm thế nào để merge các ô này vào lại thành 1 ô theo điều kiện và vẫn giữ nguyên được cấu trúc của 3 ô B1, B2, B3.

và dữ liệu ở ô sau khi gộp vào sẽ giống như ô đã merge ô A1, A2, A3 vào không ạ.

Nhờ các thầy giúp em, em cảm ơn nhiều lắm lắm ạ.

em gửi luôn file mẫu các thầy xem giúp em với

 

[Quang_Hải]

mấy vụ này mà công thức làm gì nổi chứ

 

[khocthet296]

chân thành cám ơn thầy đã giúp đỡ em ạ,
em chạy thử trên file thầy gửi không vấn đề gì ạ, nhưng khi copy sang file gốc để chạy thì gặp vấn đề lỗi error 13 thầy ạ, cụ thể nó báo ở dòng items = Application.Transpose(.items) như hình, thầy giúp em với ạ, khoản này em dốt lắm ạ.

như file thầy làm ở trên thì nó sẽ đè vào cột dữ liệu cũ ạ, thầy có thể giúp em cho nó sang cột bên cạnh được không ạ?
Cám ơn thầy rất nhiều ạ.

 

[Ba Tê]

nhờ các thầy giúp em với ạ

Tôi không thích Merge Cells, làm thử cách này xem có xài được không?
Bấm nút ở sheet2.

 

[khocthet296]

Tôi không thích Merge Cells, làm thử cách này xem có xài được không?
Bấm nút ở sheet2.

kính gửi thầy, em đã tải file của thầy và thử, với dữ liệu như ở sheet 1 thì GPE xử lý rất ok,
nhưng với dữ liệu 20.000 dòng em copy thêm vào dưới dữ liệu trên thì xuất hiện lỗi ạ,
cụ thể là lỗi runtime error 457.
xin thầy xem giúp em.
Rất cám ơn thầy ạ.

Em gửi thêm file gốc để thầy nghiên cứu ạ, em cám ơn thầy lắm lắm.

 

[Ba Tê]

kính gửi thầy, em đã tải file của thầy và thử, với dữ liệu như ở sheet 1 thì GPE xử lý rất ok,
nhưng với dữ liệu 20.000 dòng em copy thêm vào dưới dữ liệu trên thì xuất hiện lỗi ạ,
cụ thể là lỗi runtime error 457.
xin thầy xem giúp em.
Rất cám ơn thầy ạ.

Em gửi thêm file gốc để thầy nghiên cứu ạ, em cám ơn thầy lắm lắm.

Tôi cũng "mù luôn", hổng hiểu tại sao vì mới tập tành VBA, có mấy cái hạn chế nào đó mà mình chưa biết.
Dữ liệu đến dòng 10861 thì chạy, thêm 1 dòng nữa là lỗi.
Híc.
Chờ các bạn có kinh nghiệm giải thích hoặc sửa code.

Public Sub GPE()
Dim Dic1 As Object, Dic2 As Object, I As Long, J As Long, K As Long
Dim Rng(), Arr()
Set Dic1 = CreateObject("scripting.dictionary")
Set Dic2 = CreateObject("scripting.dictionary")
    Rng = Sheet1.Range(Sheet1.[A1], Sheet1.[A65536].End(xlUp)).Resize(, 3).Value
ReDim Arr(1 To UBound(Rng, 1) + 1, 1 To 3)
    For I = 1 To UBound(Rng, 1)
        If Not Dic1.exists(Rng(I, 1) & Rng(I, 2)) Then
            Dic1.Add Rng(I, 1) & Rng(I, 2), ""
            Dic2.Add Rng(I, 1) & Rng(I, 2) & Rng(I, 3), ""
            K = K + 1
            Arr(K, 1) = Rng(I, 1): Arr(K, 2) = Rng(I, 2)
            Arr(K, 3) = Rng(I, 3)
        Else
            If Not Dic2.exists(Rng(I, 1) & Rng(I, 2) & Rng(I, 3)) Then
                Arr(K, 3) = Arr(K, 3) & "; " & Rng(I, 3)
            End If
        End If
    Next I
Sheet2.[A1].Resize(K, 3).Value = Arr
Set Dic1 = Nothing
Set Dic2 = Nothing
End Sub

 

[khocthet296]

Tôi cũng "mù luôn", hổng hiểu tại sao vì mới tập tành VBA, có mấy cái hạn chế nào đó mà mình chưa biết.
Dữ liệu đến dòng 10861 thì chạy, thêm 1 dòng nữa là lỗi.
Híc.
Chờ các bạn có kinh nghiệm giải thích hoặc sửa code.

Public Sub GPE()
Dim Dic1 As Object, Dic2 As Object, I As Long, J As Long, K As Long
Dim Rng(), Arr()
Set Dic1 = CreateObject("scripting.dictionary")
Set Dic2 = CreateObject("scripting.dictionary")
    Rng = Sheet1.Range(Sheet1.[A1], Sheet1.[A65536].End(xlUp)).Resize(, 3).Value
ReDim Arr(1 To UBound(Rng, 1) + 1, 1 To 3)
    For I = 1 To UBound(Rng, 1)
        If Not Dic1.exists(Rng(I, 1) & Rng(I, 2)) Then
            Dic1.Add Rng(I, 1) & Rng(I, 2), ""
            Dic2.Add Rng(I, 1) & Rng(I, 2) & Rng(I, 3), ""
            K = K + 1
            Arr(K, 1) = Rng(I, 1): Arr(K, 2) = Rng(I, 2)
            Arr(K, 3) = Rng(I, 3)
        Else
            If Not Dic2.exists(Rng(I, 1) & Rng(I, 2) & Rng(I, 3)) Then
                Arr(K, 3) = Arr(K, 3) & "; " & Rng(I, 3)
            End If
        End If
    Next I
Sheet2.[A1].Resize(K, 3).Value = Arr
Set Dic1 = Nothing
Set Dic2 = Nothing
End Sub

gửi thầy ạ, trên máy em theo như em thử thì gần nhất GPE chỉ chạy được dưới 1000 dòng thôi ạ

 

[Ba Tê]

gửi thầy ạ, trên máy em theo như em thử thì gần nhất GPE chỉ chạy được dưới 1000 dòng thôi ạ

Không biết là sao.
Trên máy tôi, sheet DuLieu có 10.861 dòng. Chuyển sang sheet GPE đến dòng 1.649 .

 

[Quang_Hải]

Mình nghĩ là CPU chiu không nổi hay sao ấy, thôi thì đành dùng tạm cách này, chậm tí nhưng trước mắt cũng giải quyết được bài toán

 

[khocthet296]

Mình nghĩ là CPU chiu không nổi hay sao ấy, thôi thì đành dùng tạm cách này, chậm tí nhưng trước mắt cũng giải quyết được bài toán

ôi dùng ok lắm thầy ạ. Em cảm ơn thầy nhiều ạ,

 

[ndu96081631]

Tôi cũng "mù luôn", hổng hiểu tại sao vì mới tập tành VBA, có mấy cái hạn chế nào đó mà mình chưa biết.
Dữ liệu đến dòng 10861 thì chạy, thêm 1 dòng nữa là lỗi.
Híc.
Chờ các bạn có kinh nghiệm giải thích hoặc sửa code.

Public Sub GPE()
Dim Dic1 As Object, Dic2 As Object, I As Long, J As Long, K As Long
Dim Rng(), Arr()
Set Dic1 = CreateObject("scripting.dictionary")
Set Dic2 = CreateObject("scripting.dictionary")
    Rng = Sheet1.Range(Sheet1.[A1], Sheet1.[A65536].End(xlUp)).Resize(, 3).Value
ReDim Arr(1 To UBound(Rng, 1) + 1, 1 To 3)
    For I = 1 To UBound(Rng, 1)
        If Not Dic1.exists(Rng(I, 1) & Rng(I, 2)) Then
            Dic1.Add Rng(I, 1) & Rng(I, 2), ""
            Dic2.Add Rng(I, 1) & Rng(I, 2) & Rng(I, 3), ""
            K = K + 1
            Arr(K, 1) = Rng(I, 1): Arr(K, 2) = Rng(I, 2)
            Arr(K, 3) = Rng(I, 3)
        Else
            If Not Dic2.exists(Rng(I, 1) & Rng(I, 2) & Rng(I, 3)) Then
                Arr(K, 3) = Arr(K, 3) & "; " & Rng(I, 3)
            End If
        End If
    Next I
Sheet2.[A1].Resize(K, 3).Value = Arr
Set Dic1 = Nothing
Set Dic2 = Nothing
End Sub

3T hãy để ý thằng Dic2 nha

If Not Dic1.exists(Rng(I, 1) & Rng(I, 2)) Then
            Dic1.Add Rng(I, 1) & Rng(I, 2), ""
            [COLOR=#ff0000][B]Dic2.Add Rng(I, 1) & Rng(I, 2) & Rng(I, 3), ""[/B][/COLOR]
            K = K + 1

Chưa kiểm tra sự tồn tại đã vội Add ---> Thế nào cũng có chuyện

 

[tvl297]

bạn thử xem có được không công thức này là của bác ndu96081631 http://www.giaiphapexcel.com/forum/...ác-đoạn-tex-trong-1-vùng-dữ-liệu-có-điều-kiện