Gộp chuỗi trùng nhau đồng thời cộng số lượng các loại (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
T

ThaiDieuAnh

Thành viên hoạt động
Tham gia
8/8/16
Bài viết
139
Được thích
24
Nghề nghiệp
Xây dựng
Giả sử em có dữ liệu tại A5 là:
Cocacola: 5; Pepsi: 2; Cam ép Twister: 3
Tại A6 là:
Pepsi: 3; Cam ép Twister: 1; Trà xanh C2: 5
Em muốn một hàm tự tạo có thể gộp những loại tên trùng nhau được phân cách bằng dấu ; và đồng thời cộng số lượng các loại đó. Kết quả trả về sẽ là:
Cocacola: 5; Pepsi: 5; Cam ép Twister: 4; Trà xanh C2: 5
Xin cảm ơn!
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
ThaiDieuAnh đã viết:
Giả sử em có dữ liệu tại A5 là:
Cocacola: 5; Pepsi: 2; Cam ép Twister: 3
Tại A6 là:
Pepsi: 3; Cam ép Twister: 1; Trà xanh C2: 5
Em muốn một hàm tự tạo có thể gộp những loại tên trùng nhau được phân cách bằng dấu ; và đồng thời cộng số lượng các loại đó. Kết quả trả về sẽ là:
Cocacola: 5; Pepsi: 5; Cam ép Twister: 4; Trà xanh C2: 5
Xin cảm ơn!
Nhấp chuột vào đây để mở rộng...
Bạn chạy code này xem:
Mã: 
Sub gop()
Dim i As Long, j As Long, str As String, str2 As String, dic As Object, arr, darr
arr = Range("A5:A" & [A65000].End(xlUp).Row)
ReDim darr(1 To 1000, 1 To 2)
Set dic = CreateObject("scripting.dictionary")
With CreateObject("vbscript.regexp")
    For i = 1 To UBound(arr)
        str = ";" & arr(i, 1)
        .Global = True: .ignorecase = True
        .Pattern = ";\s?([^\;]+:)\s?(\d+)"
        For Each Item In .Execute(str)
            If Not dic.exists(Item.submatches(0)) Then
                j = j + 1
                dic.Add Item.submatches(0), j
                darr(j, 1) = Item.submatches(0): darr(j, 2) = CLng(Item.submatches(1))
            Else
                darr(dic.Item(Item.submatches(0)), 2) = darr(dic.Item(Item.submatches(0)), 2) + CLng(Item.submatches(1))
            End If
        Next
    Next
    For i = 1 To j
        str2 = str2 & darr(i, 1) & " " & darr(i, 2) & IIf(i = j, "", "; ")
    Next
    [c5].Resize(1, 1) = str2
End With
End Sub
 
Upvote 0
excel_lv1.5 đã viết:
Bạn chạy code này xem:
Mã: 
Sub gop()
Dim i As Long, j As Long, str As String, str2 As String, dic As Object, arr, darr
arr = Range("A5:A" & [A65000].End(xlUp).Row)
ReDim darr(1 To 1000, 1 To 2)
Set dic = CreateObject("scripting.dictionary")
With CreateObject("vbscript.regexp")
    For i = 1 To UBound(arr)
        str = ";" & arr(i, 1)
        .Global = True: .ignorecase = True
        .Pattern = ";\s?([^\;]+:)\s?(\d+)"
        For Each Item In .Execute(str)
            If Not dic.exists(Item.submatches(0)) Then
                j = j + 1
                dic.Add Item.submatches(0), j
                darr(j, 1) = Item.submatches(0): darr(j, 2) = CLng(Item.submatches(1))
            Else
                darr(dic.Item(Item.submatches(0)), 2) = darr(dic.Item(Item.submatches(0)), 2) + CLng(Item.submatches(1))
            End If
        Next
    Next
    For i = 1 To j
        str2 = str2 & darr(i, 1) & " " & darr(i, 2) & IIf(i = j, "", "; ")
    Next
    [c5].Resize(1, 1) = str2
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Code chạy chuẩn bác excel_lv1.5 ạ. Tuy nhiên có cách gì thay sub này thành hàm được không bác.
 
Upvote 0
ThaiDieuAnh đã viết:
Code chạy chuẩn bác excel_lv1.5 ạ. Tuy nhiên có cách gì thay sub này thành hàm được không bác.
Nhấp chuột vào đây để mở rộng...
Vậy bạn chỉnh code lại chút:
Mã: 
Function gop(rng As Range)
Dim i As Long, j As Long, str As String, str2 As String, dic As Object, arr, darr
arr = rng
ReDim darr(1 To 1000, 1 To 2)
Set dic = CreateObject("scripting.dictionary")
With CreateObject("vbscript.regexp")
    For i = 1 To UBound(arr)
        str = ";" & arr(i, 1)
        .Global = True: .ignorecase = True
        .Pattern = ";\s?([^\;]+:)\s?(\d+)"
        For Each Item In .Execute(str)
            If Not dic.exists(Item.submatches(0)) Then
                j = j + 1
                dic.Add Item.submatches(0), j
                darr(j, 1) = Item.submatches(0): darr(j, 2) = CLng(Item.submatches(1))
            Else
                darr(dic.Item(Item.submatches(0)), 2) = darr(dic.Item(Item.submatches(0)), 2) + CLng(Item.submatches(1))
            End If
        Next
    Next
    For i = 1 To j
        str2 = str2 & darr(i, 1) & " " & darr(i, 2) & IIf(i = j, "", "; ")
    Next
    gop = str2
End With
End Function
Dùng hàm =gop(A5:A6)
 
Upvote 0
excel_lv1.5 đã viết:
Vậy bạn chỉnh code lại chút:
Mã: 
Function gop(rng As Range)
Dim i As Long, j As Long, str As String, str2 As String, dic As Object, arr, darr
arr = rng
ReDim darr(1 To 1000, 1 To 2)
Set dic = CreateObject("scripting.dictionary")
With CreateObject("vbscript.regexp")
    For i = 1 To UBound(arr)
        str = ";" & arr(i, 1)
        .Global = True: .ignorecase = True
        .Pattern = ";\s?([^\;]+:)\s?(\d+)"
        For Each Item In .Execute(str)
            If Not dic.exists(Item.submatches(0)) Then
                j = j + 1
                dic.Add Item.submatches(0), j
                darr(j, 1) = Item.submatches(0): darr(j, 2) = CLng(Item.submatches(1))
            Else
                darr(dic.Item(Item.submatches(0)), 2) = darr(dic.Item(Item.submatches(0)), 2) + CLng(Item.submatches(1))
            End If
        Next
    Next
    For i = 1 To j
        str2 = str2 & darr(i, 1) & " " & darr(i, 2) & IIf(i = j, "", "; ")
    Next
    gop = str2
End With
End Function
Dùng hàm =gop(A5:A6)
Nhấp chuột vào đây để mở rộng...
Khi em dùng hàm = gop(A5) hoặc =gop(A5:A5) thì hàm báo #VALUE!, mà kết quả em mong muốn trong trường hợp này là trả về giá trị ô A5 luôn. Cộng với khi gán công thức trong VBA, chẳng hạn:
Mã: 
darr(k, 1) = gop(sArr(i, 2))
thì hàm báo lỗi:
Mã: 
ByRef argument type mismatch
Mong các bác giúp đỡ, em xin cảm ơn
 
Upvote 0
ThaiDieuAnh đã viết:
Khi em dùng hàm = gop(A5) hoặc =gop(A5:A5) thì hàm báo #VALUE!, mà kết quả em mong muốn trong trường hợp này là trả về giá trị ô A5 luôn. Cộng với khi gán công thức trong VBA, chẳng hạn:
Mã: 
darr(k, 1) = gop(sArr(i, 2))
thì hàm báo lỗi:
Mã: 
ByRef argument type mismatch
Mong các bác giúp đỡ, em xin cảm ơn
Nhấp chuột vào đây để mở rộng...
Bạn hiền dùng hàng phổ thông này xem sao
Mã: 
Public Function MyJoin(Rng)
Dim SArr, Cll, Tmp, i
SArr = Rng

If IsArray(SArr) = False Then
    MyJoin = Rng
Else
    With CreateObject("Scripting.Dictionary")
    For Each Cll In SArr
        For Each Tmp In Split(Cll, ";")
            Tmp = Split(Tmp, ":")
            .Item(Trim(Tmp(0))) = .Item(Trim(Tmp(0))) + CLng(Trim(Tmp(1)))
        Next Tmp
    Next Cll
    Tmp = .keys()(0) & ": " & .items()(0)
    For i = 1 To .Count - 1
        Tmp = Tmp & "; " & .keys()(i) & ": " & .items()(i)
    Next i
    MyJoin = Tmp
    End With
End If
End Function
 
Lần chỉnh sửa cuối:
Upvote 0
TheThienChu đã viết:
Bạn hiền dùng hàng phổ thông này xem sao
Mã: 
Public Function MyJoin(Rng)
Dim SArr, Cll, Tmp, i
SArr = Rng

If IsArray(SArr) = False Then
    MyJoin = Rng
Else
    With CreateObject("Scripting.Dictionary")
    For Each Cll In SArr
        For Each Tmp In Split(Cll, ";")
            Tmp = Split(Tmp, ":")
            .Item(Trim(Tmp(0))) = .Item(Trim(Tmp(0))) + CLng(Trim(Tmp(1)))
        Next Tmp
    Next Cll
    Tmp = .keys()(0) & ": " & .items()(0)
    For i = 1 To .Count - 1
        Tmp = Tmp & "; " & .keys()(i) & ": " & .items()(i)
    Next i
    MyJoin = Tmp
    End With
End If
End Function
Nhấp chuột vào đây để mở rộng...
Cảm ơn bác, nhưng hàm của bác không chạy được bác ạ
 

File đính kèm

Upvote 0
Upvote 0
Cảm ơn các bác rất rất nhiều ạ, em đang làm cái QLCL cho công ty, theo em biết cái này bác PacificPR rất siêu. Có cách gì nói chuyện riêng được với các bác làm cái này không ạ. Em có rất nhiều thứ muốn trao đổi mà không biết làm thế nào. Mong các bác giúp đỡ
 
Upvote 0
ThaiDieuAnh đã viết:
Cảm ơn các bác rất rất nhiều ạ, em đang làm cái QLCL cho công ty, theo em biết cái này bác PacificPR rất siêu. Có cách gì nói chuyện riêng được với các bác làm cái này không ạ. Em có rất nhiều thứ muốn trao đổi mà không biết làm thế nào. Mong các bác giúp đỡ
Nhấp chuột vào đây để mở rộng...
Bạn lập Topic và đưa cái dự án đó lên mọi người trên diễn đàn sẽ giúp bạn
Mà sao HS QLCL lại liên quan đến CCocacola; Pepsi; Cam ép Twister ... vậy. Hay là cái này để cho cán bộ kỹ thuật giải khát khi làm việc :p
 
Upvote 0
PacificPR đã viết:
Bạn lập Topic và đưa cái dự án của mình lên mọi người trên diễn đàn sẽ giúp bạn
Mà sao HS QLCL lại liên quan đến CCocacola; Pepsi; Cam ép Twister ... vậy. Hay là cái này để cho cán bộ kỹ thuật giải khát khi làm việc :p
Nhấp chuột vào đây để mở rộng...
Cảm ơn bác đã quan tâm, cũng vì file bây giờ cũng nhiều dữ liệu mà em chưa quy hoạch được gọn gàng nên nhìn rất rối. Toàn bộ code đều từ GPE + của bác trước đây chia sẻ mà chế tác cho phù hợp với yêu cầu của mình bác ạ. Em đưa file mà toàn coca với pepsi là tương ứng với thiết bị công trình đó bác :p. Bác có mail thì nhắn giúp để em gửi file nhờ bác tý ạ!
 
Upvote 0
ThaiDieuAnh đã viết:
Cảm ơn bác đã quan tâm, cũng vì file bây giờ cũng nhiều dữ liệu mà em chưa quy hoạch được gọn gàng nên nhìn rất rối. Toàn bộ code đều từ GPE + của bác trước đây chia sẻ mà chế tác cho phù hợp với yêu cầu của mình bác ạ. Em đưa file mà toàn coca với pepsi là tương ứng với thiết bị công trình đó bác :p. Bác có mail thì nhắn giúp để em gửi file nhờ bác tý ạ!
Nhấp chuột vào đây để mở rộng...
Gửi lên đây luôn nhiều người làm sẽ có nhiều cách khác nhau. Từ đó bạn sẽ chọn được phương án tối ưu nhất cho mình :D
 
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

J
Công thức tính lương khi mỗi tháng tăng lương cơ bản
Trả lời
0
Đọc
10
jangne88
J
V
  • Question Question
Đếm xếp loại của đơn hàng (1 người xem)
Trả lời
7
Đọc
115
bebo021999
B
HeSanbi
  • Question Question
Sự khác nhau giữa book.Worksheets và book.Sheets trong Application
Trả lời
0
Đọc
29
HeSanbi
HeSanbi
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
15 16 17
Trả lời
325
Đọc
24K
ongke0711
ongke0711
Việt Nguyễn 86
Excel hay bị tắt đột ngột và hiện trang trắng khi làm việc
Trả lời
6
Đọc
210
HeSanbi
HeSanbi
phatnguyen7301
  • Question Question
Viết code không trùng dữ liệu
Trả lời
2
Đọc
65
SA_DQ
SA_DQ
Manhhung90
Thoát chế độ Read only file word. Nhờ mọi người giúp ạ
Trả lời
5
Đọc
79
Manhhung90
Manhhung90
H
chuyển dữ liệu từ 1 dòng thành nhiều dòng theo điều kiện cho trước.
Trả lời
3
Đọc
91
hanhnguyen12022021
H
N
Không chạy được file VBA
Trả lời
2
Đọc
89
hoangtuan.net
hoangtuan.net
H
Quản Lý Công Văn đi Và đến (1 người xem)
9 10 11
Trả lời
214
Đọc
159K
ptm0412
ptm0412
T
Em muốn xin chỉ giáo file excel theo dõi thu chi, lãi lỗ của từng xe để báo cáo ạ
Trả lời
3
Đọc
86
VetMini
V
S
RemoveDuplicates Adodb VBA
Trả lời
0
Đọc
71
sykika
S
G
  • Question Question
BẢO MẬT VBAPROJECT
Trả lời
0
Đọc
125
giaoluu1231
G
sangvanng92
  • Question Question
Phân quyền user truy cập
Trả lời
9
Đọc
180
Hoàng Tuấn 868
H
DinhManh1307
Cách thống kê công việc sản xuất từng người để tính lương sản phẩm
Trả lời
7
Đọc
151
DinhManh1307
DinhManh1307
PhanTuHuong
Hà Nội hẹn hò gặp gỡ đầu năm 2025 thôi :)
    • Thích
    • Yêu thích
Trả lời
6
Đọc
307
tranhungdao12a3
T
GPE-Trợ Lý
[GPE] TALKSHOW KHÁM PHÁ SỨC MẠNH HÀM FILTER TRONG EXCEL 365 (1 người xem)
Trả lời
0
Đọc
2K
GPE-Trợ Lý
GPE-Trợ Lý
befaint
Chia sẻ tâm tư, xả nỗi lòng (1 người xem)
    • Thích
36 37 38
Trả lời
759
Đọc
49K
befaint
befaint
H
Quên mật khẩu khóa protect
Trả lời
18
Đọc
286
HeSanbi
HeSanbi
NguyenNgocThuHien
  • Question Question
Liệt kê tổ hợp chập k của nhóm n phần tử.
    • Thích
    • Yêu thích
2 3
Trả lời
54
Đọc
17K
phương Đức
P
Xem thêm…

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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALKSHOW KHÁM PHÁ SỨC MẠNH HÀM FILTER TRONG EXCEL 365
Back
Top Bottom