Xin hỏi cách gom các ô đồng dạng!

Liên hệ QC
win-sun

win-sun

Thành viên hoạt động
Tham gia
19/1/09
Bài viết
151
Được thích
15
Xin nhờ các Pro chỉ giúp, em có dữ liệu dạng này (tên thiết bị giống nhau chỉ khác số nhận dạng) và cần gom gọn lại, cam on!

Tên thiết bị

Số nhận dạng

Máy mài Makita 9500

MMT-1

Máy mài Makita 9500

MMT-2

Máy mài Makita 9500

MMT-3

Máy mài Makita 9500

MMT-4

Máy khoan Makita 8416

MKT-1

Máy khoan Makita 8416

MKT-2

Máy khoan Makita 8416

MKT-3

Máy khoan Makita 8416

MKT-4

Mong ước



Máy mài Makita 9500

MMT-1, MMT-2, MMT-3, MMT-4

Máy khoan Makita 8416

MKT-1, MKT-2, MKT-3, MKT-4
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Hỏi cách làm hay nhờ viết code giùm?
Pờ rồ với pờ riếc. Tiếng Việt thì tập nói cho rõ đi, đua đòi chêm tiếng Tây.

Nếu nhờ viết code thì chắc không sao. Loại bài dùng đit sần này nhiều người thích làm lắm.
 
Upvote 0
Code trên Class Module "sanpham":
Mã: 
Private ten As String
Private mnd As String

Property Get Name() As String
    Name = ten
End Property

Property Let Name(s As String)
    ten = s
End Property

Property Get Id() As String
    Id = mnd
End Property

Property Let Id(s As String)
    mnd = s
End Property

Code trên module 1
Mã: 
Public arr()
Sub lietkeketqua()
    Dim i As Integer
    Dim rend As Integer
    Dim s    As String
    Dim s2   As String
    Dim s3   As String
   
   
    Dim snguon  As String
   
   
    Dim cnt As Integer
    Dim stt As Integer
   
   
    rend = ThisWorkbook.Sheets("DATA").Range("B" & Rows.Count).End(xlUp).Row
    snguon = ""
    mndnguon = ""
    cnt = 0
    If rend < 2 Then Exit Sub
   
    For i = 2 To rend Step 1
        s = ThisWorkbook.Sheets("DATA").Cells(i, 2).Value
        s2 = ThisWorkbook.Sheets("DATA").Cells(i, 3).Value
        If s <> "" Then
            If InStr(1, snguon, s) = 0 Then
                snguon = snguon & "," & s
                cnt = cnt + 1
                If cnt = 1 Then
                    ReDim arr(1 To cnt)
                Else
                    ReDim Preserve arr(1 To cnt)
                End If
                    Set arr(cnt) = New sanpham
                    arr(cnt).Name = s
                    arr(cnt).Id = s2
                   
            Else
                    stt = timarr(s)
                    s3 = arr(stt).Id
                    arr(stt).Id = s3 & "," & s2
            End If
        End If
    Next i
    For i = LBound(arr, 1) To UBound(arr, 1) Step 1
        ThisWorkbook.Sheets("KETQUA").Cells(i, 2).Value = arr(i).Name
        ThisWorkbook.Sheets("KETQUA").Cells(i, 3).Value = arr(i).Id
    Next i
End Sub
Function timarr(tensp As String) As Integer
    For i = LBound(arr, 1) To UBound(arr, 1) Step 1
        If arr(i).Name = tensp Then
            timarr = i
            Exit Function
        End If
    Next i
End Function
 
Upvote 0
Cảm ơn bác
khongtu19bk
rất nhiều, bác có thể hướng dẫn thêm chút nữa được không, mở rộng bảng dữ liệu từ cột A đến cột K luôn, xin chân thành cảm ơn.
 
Upvote 0
win-sun đã viết:
Xin nhờ các Pro chỉ giúp, em có dữ liệu dạng này (tên thiết bị giống nhau chỉ khác số nhận dạng) và cần gom gọn lại, cam on!

Tên thiết bị

Số nhận dạng

Máy mài Makita 9500

MMT-1

Máy mài Makita 9500

MMT-2

Máy mài Makita 9500

MMT-3

Máy mài Makita 9500

MMT-4

Máy khoan Makita 8416

MKT-1

Máy khoan Makita 8416

MKT-2

Máy khoan Makita 8416

MKT-3

Máy khoan Makita 8416

MKT-4

Mong ước



Máy mài Makita 9500

MMT-1, MMT-2, MMT-3, MMT-4

Máy khoan Makita 8416

MKT-1, MKT-2, MKT-3, MKT-4
Nhấp chuột vào đây để mở rộng...

Hàm tự tạo nhé!
Mã: 
Function gom(champ As Range)
  Application.Volatile
  Set vung = CreateObject("Scripting.Dictionary")
  For Each c In champ
   If c.Value <> "" Then
     If Not vung.exists(c.Value) Then
       vung(c.Value) = c.Offset(, 1).Value
     Else
       vung(c.Value) = vung(c.Value) & ", " & c.Offset(, 1).Value
     End If
  End If
  Next c
  Dim b()
  ReDim b(1 To Application.Caller.Rows.Count, 1 To 2)
  i = 1
  For Each c In vung.keys
     b(i, 1) = c
     b(i, 2) = vung.Item(c)
     i = i + 1
  Next
  gom = b
End Function
 

File đính kèm

  • gom theo hinh.xlsm
    15.6 KB · Đọc: 9
Upvote 0
win-sun đã viết:
Cảm ơn bác
khongtu19bk
rất nhiều, bác có thể hướng dẫn thêm chút nữa được không, mở rộng bảng dữ liệu từ cột A đến cột K luôn, xin chân thành cảm ơn.
Nhấp chuột vào đây để mở rộng...
Đầu tiên bạn xem video này để hiểu cách lấy dòng cuối cùng và hiểu lệnh instr có trong code.
Sau đó bạn xem video này để hiểu về biến toàn cục và mảng, khai báo mảng giữ giá trị phần tử mảng trước đó preserve.
Bạn nên xem video bằng máy tính và chọn chế độ HD 1080.
Các vấn đề khác sẽ tiếp tục trình bày ở các video tiếp theo.
 
Upvote 0
sao công thức không xóa được hả bác !
 

File đính kèm

  • 1555682263157.png
    1555682263157.png
    16 KB · Đọc: 6
Upvote 0
khongtu19bk đã viết:
Công thức nào không xóa được vậy bạn?
Nhấp chuột vào đây để mở rộng...
Không xóa được ở hàm tự tạo bác ah, cảm ơn bác đã giúp! nếu bảng data rộng hơn từ cột A đến cột K thì làm sao ah, sắp xếp cột tên sản phâm và số nhận dạng vậy là đúng ý rồi, còn thông tin các cột khác vẫn giữ lại theo dòng được không bác, cam on.
 
Upvote 0
khi số lượng thiết bị nhiều dòng thì code chạy rất chậm, mong moi người chỉ giúp, cam on
 

File đính kèm

  • Book1.xlsb
    23.3 KB · Đọc: 8
Upvote 0
1. Không xóa được hàm tự tạo -> Không hiểu, hãy chỉ cụ thể là hàm gì bằng hình ảnh
2. Code chạy rất chậm cụ thể là với data như thế nào? File bạn đưa lên data chỉ có 13 dòng thì mình không nghĩ là chậm.
Cụ thể là mất bao nhiêu time.
File dữ liệu nhiều dòng cụ thể là file nào, hãy đưa lên, định dạng xlsm thì càng tốt.
 
Upvote 0
win-sun đã viết:
Xin nhờ các Pro chỉ giúp, em có dữ liệu dạng này (tên thiết bị giống nhau chỉ khác số nhận dạng) và cần gom gọn lại, cam on!

Tên thiết bị

Số nhận dạng

Máy mài Makita 9500

MMT-1

Máy mài Makita 9500

MMT-2

Máy mài Makita 9500

MMT-3

Máy mài Makita 9500

MMT-4

Máy khoan Makita 8416

MKT-1

Máy khoan Makita 8416

MKT-2

Máy khoan Makita 8416

MKT-3

Máy khoan Makita 8416

MKT-4

Mong ước



Máy mài Makita 9500

MMT-1, MMT-2, MMT-3, MMT-4

Máy khoan Makita 8416

MKT-1, MKT-2, MKT-3, MKT-4
Nhấp chuột vào đây để mở rộng...

Anh thử sub này nếu dữ liệu nhiều

Mã: 
Sub GopDuLieu()
Dim sarr, rarr()
Dim dic As Object
Dim Cot_DL As Long, Cot_KQ As Long, lr As Long, Tong As Long
Set dic = CreateObject("scripting.dictionary")
With Sheets("Sheet1")
    lr = .Range("A" & Rows.Count).End(xlUp).Row
    sarr = .Range("A1:B" & lr).Value
    ReDim rarr(1 To UBound(sarr), 1 To 2)
    For Cot_DL = 1 To UBound(sarr)
        
            If Not dic.exists(sarr(Cot_DL, 1)) Then
                Cot_KQ = Cot_KQ + 1
                dic.Add sarr(Cot_DL, 1), Cot_KQ
                rarr(Cot_KQ, 1) = sarr(Cot_DL, 1)
                rarr(Cot_KQ, 2) = sarr(Cot_DL, 2)
            Else
                Tong = dic.Item(sarr(Cot_DL, 1))
                rarr(Tong, 2) = rarr(Tong, 2) & ", " & sarr(Cot_DL, 2)
            End If
    Next Cot_DL
    .Range("D1:E" & lr).ClearContents
    .Range("D1").Resize(Cot_KQ, 2) = rarr
End With
End Sub
 

File đính kèm

  • gom theo hinh.xlsm
    18.5 KB · Đọc: 5
Upvote 0
nhờ bạn xem giúp, xin cam on
 

File đính kèm

  • Book1.xlsm
    19.1 KB · Đọc: 5
Upvote 0
Anh LamNA vui lòng chỉnh giúp tôi kết quả như file nha, cam on anh nhieu lam
Sub GopDuLieu()
Dim sarr, rarr()
Dim dic As Object
Dim Cot_DL As Long, Cot_KQ As Long, lr As Long, Tong As Long
Set dic = CreateObject("scripting.dictionary")
With Sheets("data")
lr = .Range("A" & Rows.Count).End(xlUp).Row
sarr = .Range("A1:B" & lr).Value
ReDim rarr(1 To UBound(sarr), 1 To 2)
For Cot_DL = 1 To UBound(sarr)

If Not dic.exists(sarr(Cot_DL, 1)) Then
Cot_KQ = Cot_KQ + 1
dic.Add sarr(Cot_DL, 1), Cot_KQ
rarr(Cot_KQ, 1) = sarr(Cot_DL, 1)
rarr(Cot_KQ, 2) = sarr(Cot_DL, 2)
Else
Tong = dic.Item(sarr(Cot_DL, 1))
rarr(Tong, 2) = rarr(Tong, 2) & ", " & sarr(Cot_DL, 2)
End If
Next Cot_DL
Sheets("ketqua").Range("A2:E" & lr).ClearContents
Sheets("ketqua").Range("A2").Resize(Cot_KQ, 2) = rarr
End With
End Sub
 

File đính kèm

  • Book1.xlsm
    16.5 KB · Đọc: 4
Upvote 0
win-sun đã viết:
Anh LamNA vui lòng chỉnh giúp tôi kết quả như file nha, cam on anh nhieu lam
Sub GopDuLieu()
Dim sarr, rarr()
Dim dic As Object
Dim Cot_DL As Long, Cot_KQ As Long, lr As Long, Tong As Long
Set dic = CreateObject("scripting.dictionary")
With Sheets("data")
lr = .Range("A" & Rows.Count).End(xlUp).Row
sarr = .Range("A1:B" & lr).Value
ReDim rarr(1 To UBound(sarr), 1 To 2)
For Cot_DL = 1 To UBound(sarr)

If Not dic.exists(sarr(Cot_DL, 1)) Then
Cot_KQ = Cot_KQ + 1
dic.Add sarr(Cot_DL, 1), Cot_KQ
rarr(Cot_KQ, 1) = sarr(Cot_DL, 1)
rarr(Cot_KQ, 2) = sarr(Cot_DL, 2)
Else
Tong = dic.Item(sarr(Cot_DL, 1))
rarr(Tong, 2) = rarr(Tong, 2) & ", " & sarr(Cot_DL, 2)
End If
Next Cot_DL
Sheets("ketqua").Range("A2:E" & lr).ClearContents
Sheets("ketqua").Range("A2").Resize(Cot_KQ, 2) = rarr
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Anh thử lại
Mã: 
Sub GopDuLieu()
Dim sarr, rarr()
Dim dic As Object
Dim Cot_DL As Long, Cot_KQ As Long, lr As Long, Tong As Long
Set dic = CreateObject("scripting.dictionary")
With Sheets("data")
    lr = .Range("A" & Rows.Count).End(xlUp).Row
    sarr = .Range("A2:E" & lr).Value
    ReDim rarr(1 To UBound(sarr), 1 To 5)
    For Cot_DL = 1 To UBound(sarr)
        
            If Not dic.exists(sarr(Cot_DL, 2)) Then
                Cot_KQ = Cot_KQ + 1
                dic.Add sarr(Cot_DL, 2), Cot_KQ
                rarr(Cot_KQ, 1) = sarr(Cot_DL, 1)
                rarr(Cot_KQ, 2) = sarr(Cot_DL, 2)
                rarr(Cot_KQ, 3) = sarr(Cot_DL, 3)
                rarr(Cot_KQ, 4) = sarr(Cot_DL, 4)
                rarr(Cot_KQ, 5) = sarr(Cot_DL, 5)
            Else
                Tong = dic.Item(sarr(Cot_DL, 2))
                rarr(Tong, 3) = rarr(Tong, 3) & ", " & sarr(Cot_DL, 3)
            End If
    Next Cot_DL
    End With
    With Sheets("KETQUA")
    Sheets("ketqua").Range("A2:E" & lr).ClearContents
    Sheets("ketqua").Range("A2").Resize(Cot_KQ, 5) = rarr
End With
End Sub
 

File đính kèm

  • Book1.xlsm
    23.5 KB · Đọc: 5
Upvote 0
win-sun đã viết:
Anh LamNA vui lòng chỉnh giúp tôi kết quả như file nha, cam on anh nhieu lam
Sub GopDuLieu()
Dim sarr, rarr()
Dim dic As Object
Dim Cot_DL As Long, Cot_KQ As Long, lr As Long, Tong As Long
Set dic = CreateObject("scripting.dictionary")
With Sheets("data")
lr = .Range("A" & Rows.Count).End(xlUp).Row
sarr = .Range("A1:B" & lr).Value
ReDim rarr(1 To UBound(sarr), 1 To 2)
For Cot_DL = 1 To UBound(sarr)

If Not dic.exists(sarr(Cot_DL, 1)) Then
Cot_KQ = Cot_KQ + 1
dic.Add sarr(Cot_DL, 1), Cot_KQ
rarr(Cot_KQ, 1) = sarr(Cot_DL, 1)
rarr(Cot_KQ, 2) = sarr(Cot_DL, 2)
Else
Tong = dic.Item(sarr(Cot_DL, 1))
rarr(Tong, 2) = rarr(Tong, 2) & ", " & sarr(Cot_DL, 2)
End If
Next Cot_DL
Sheets("ketqua").Range("A2:E" & lr).ClearContents
Sheets("ketqua").Range("A2").Resize(Cot_KQ, 2) = rarr
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Thử một code tà đạo xem sao.
Vào Sheet2 nhấn nút nó lấy dữ liệu Sheet1 vào Sheet2 và ra kết quả.
 

File đính kèm

  • Gộp Cell giống nhau.xlsm
    26.1 KB · Đọc: 9
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

phanmoi688
[Xin nhờ giúp đỡ] Cách đối chiếu dữ liệu giữa hai biểu
    • Thích
Trả lời
5
Đọc
55
HUONGHCKT
H
O
Nhờ sửa code tự động trừ đi một giá trị trong vùng được chọn
Trả lời
2
Đọc
21
Phuocam
Phuocam
A
  • Question
cách dùng lockxls bảo vệ file
Trả lời
14
Đọc
3K
YêuCN
Y
LuuAnh980
Ổ đĩa mạng có màu đỏ.
Trả lời
9
Đọc
117
LuuAnh980
LuuAnh980
T
Giúp em công thức về hàm sum với bảng tính có trộn ô
Trả lời
6
Đọc
101
Thư Tín
T
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

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

Back
Top Bottom