Code Tự động gộp ô tương ứng giữa 2 cột

Liên hệ QC
pingping2288

pingping2288

Thành viên chính thức
Tham gia
1/11/11
Bài viết
86
Được thích
1
Em có 1 file như này, bao gồm 1 sheet gốc và 1 sheet đích, những ô gộp chung em đã bôi vàng và phải giữ nguyên nội dung. Em nhờ các bác có code để thực hiện tự động những thao tác này được không ạ vì những thao tác này được lặp lại rất nhiều lần! Em cám ơn trước ạ!
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
pingping2288 đã viết:
Em có 1 file như này, bao gồm 1 sheet gốc và 1 sheet đích, những ô gộp chung em đã bôi vàng và phải giữ nguyên nội dung. Em nhờ các bác có code để thực hiện tự động những thao tác này được không ạ vì những thao tác này được lặp lại rất nhiều lần! Em cám ơn trước ạ!
Nhấp chuột vào đây để mở rộng...
Bạn thử cái này nhé.
Mã: 
Sub gop()
Dim arr, i As Long, dic As Object, lr As Long, dk As Long, kq, b As Long, a As Long
Set dic = CreateObject("scripting.dictionary")
    With Sheets("file goc")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:C" & lr).Value2
         ReDim kq(1 To UBound(arr), 1 To 3)
    End With
        For i = 1 To UBound(arr)
            dk = arr(i, 2)
            If Not dic.exists(dk) Then
               a = a + 1
               kq(a, 1) = arr(i, 1)
               kq(a, 2) = arr(i, 2)
               kq(a, 3) = arr(i, 3)
               dic.Add dk, a
            Else
               b = dic.Item(dk)
               kq(b, 3) = kq(b, 3) & Chr(10) & arr(i, 3)
            End If
       Next i
    With Sheets("ketqua")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr > 1 Then .Range("A2:C" & lr).ClearContents
         If a Then .Range("A2:C2").Resize(a).Value = kq
    End With
    Set dic = Nothing
End Sub
 

File đính kèm

Upvote 0
snow25 đã viết:
Bạn thử cái này nhé.
Mã: 
Sub gop()
Dim arr, i As Long, dic As Object, lr As Long, dk As Long, kq, b As Long, a As Long
Set dic = CreateObj
[QUOTE="snow25, post: 929710, member: 1166775"]
Sub gop() Dim arr, i As Long, dic As Object, lr As Long, dk As Long, kq, b As Long, a As Long Set dic = CreateObject("scripting.dictionary") With Sheets("file goc") lr = .Range("B" & Rows.Count).End(xlUp).Row arr = .Range("A2:C" & lr).Value2 ReDim kq(1 To UBound(arr), 1 To 3) End With For i = 1 To UBound(arr) dk = arr(i, 2) If Not dic.exists(dk) Then a = a + 1 kq(a, 1) = arr(i, 1) kq(a, 2) = arr(i, 2) kq(a, 3) = arr(i, 3) dic.Add dk, a Else b = dic.Item(dk) kq(b, 3) = kq(b, 3) & Chr(10) & arr(i, 3) End If Next i With Sheets("ketqua") lr = .Range("B" & Rows.Count).End(xlUp).Row If lr > 1 Then .Range("A2:C" & lr).ClearContents If a Then .Range("A2:C2").Resize(a).Value = kq End With Set dic = Nothing End Sub
[/QUOTE]

ect("scripting.dictionary")
    With Sheets("file goc")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:C" & lr).Value2
         ReDim kq(1 To UBound(arr), 1 To 3)
    End With
        For i = 1 To UBound(arr)
            dk = arr(i, 2)
            If Not dic.exists(dk) Then
               a = a + 1
               kq(a, 1) = arr(i, 1)
               kq(a, 2) = arr(i, 2)
               kq(a, 3) = arr(i, 3)
               dic.Add dk, a
            Else
               b = dic.Item(dk)
               kq(b, 3) = kq(b, 3) & Chr(10) & arr(i, 3)
            End If
       Next i
    With Sheets("ketqua")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr > 1 Then .Range("A2:C" & lr).ClearContents
         If a Then .Range("A2:C2").Resize(a).Value = kq
    End With
    Set dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Em làm được rồi, cám ơn bác nhiều nhiều, chúc bác sức khỏe ạ!
Bài đã được tự động gộp:

snow25 đã viết:
Bạn thử cái này nhé.
Mã: 
Sub gop()
Dim arr, i As Long, dic As Object, lr As Long, dk As Long, kq, b As Long, a As Long
Set dic = CreateObject("scripting.dictionary")
    With Sheets("file goc")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:C" & lr).Value2
         ReDim kq(1 To UBound(arr), 1 To 3)
    End With
        For i = 1 To UBound(arr)
            dk = arr(i, 2)
            If Not dic.exists(dk) Then
               a = a + 1
               kq(a, 1) = arr(i, 1)
               kq(a, 2) = arr(i, 2)
               kq(a, 3) = arr(i, 3)
               dic.Add dk, a
            Else
               b = dic.Item(dk)
               kq(b, 3) = kq(b, 3) & Chr(10) & arr(i, 3)
            End If
       Next i
    With Sheets("ketqua")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr > 1 Then .Range("A2:C" & lr).ClearContents
         If a Then .Range("A2:C2").Resize(a).Value = kq
    End With
    Set dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Em hỏi chút nữa ạ! Cái cột số thứ tự sao nó không chạy lần lượt mà lại nhảy cách thế ạ?Bác giúp em xíu nữa ạ!
 
Upvote 0
pingping2288 đã viết:
Em làm được rồi, cám ơn bác nhiều nhiều, chúc bác sức khỏe ạ!
Bài đã được tự động gộp:


Em hỏi chút nữa ạ! Cái cột số thứ tự sao nó không chạy lần lượt mà lại nhảy cách thế ạ?Bác giúp em xíu nữa ạ!
Nhấp chuột vào đây để mở rộng...
Tại bạn để như vậy trong file mẫu mà.
Mã: 
Sub gop()
Dim arr, i As Long, dic As Object, lr As Long, dk As Long, kq, b As Long, a As Long
Set dic = CreateObject("scripting.dictionary")
    With Sheets("file goc")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:C" & lr).Value2
         ReDim kq(1 To UBound(arr), 1 To 3)
    End With
        For i = 1 To UBound(arr)
            dk = arr(i, 2)
            If Not dic.exists(dk) Then
               a = a + 1
               kq(a, 1) = a
               kq(a, 2) = arr(i, 2)
               kq(a, 3) = arr(i, 3)
               dic.Add dk, a
            Else
               b = dic.Item(dk)
               kq(b, 3) = kq(b, 3) & Chr(10) & arr(i, 3)
            End If
       Next i
    With Sheets("ketqua")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr > 1 Then .Range("A2:C" & lr).ClearContents
         If a Then .Range("A2:C2").Resize(a).Value = kq
    End With
    Set dic = Nothing
End Sub
Bạn thử cái này.
 
Upvote 0
buiquangthuan đã viết:
Anh ( chị) ơi. Cho em hỏi ở đoạn code có Chr(10) nghĩa là gì thế ạ
Nhấp chuột vào đây để mở rộng...
Bạn chịu khó tìm trên diễn đàn nhé:
www.giaiphapexcel.com

Hỏi ý nghĩa của "Chr()"

Mình xin hỏi: các đoạn code mà các anh chị viết trong VBA, thường có các câu lệnh "chr(13) chr(255) ..." như vậy nghĩa là sao, và nó quy định cho cái gì, bảng quy định đó như thế nào có thể giúp mình biết thông tin về quy định đó với nhá. Xin cảm ơn!
www.giaiphapexcel.com www.giaiphapexcel.com
Bài đã được tự động gộp:

snow25 đã viết:
Tại bạn để như vậy trong file mẫu mà.
Mã: 
Sub gop()
Dim arr, i As Long, dic As Object, lr As Long, dk As Long, kq, b As Long, a As Long
Set dic = CreateObject("scripting.dictionary")
    With Sheets("file goc")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:C" & lr).Value2
         ReDim kq(1 To UBound(arr), 1 To 3)
    End With
        For i = 1 To UBound(arr)
            dk = arr(i, 2)
            If Not dic.exists(dk) Then
               a = a + 1
               kq(a, 1) = a
               kq(a, 2) = arr(i, 2)
               kq(a, 3) = arr(i, 3)
               dic.Add dk, a
            Else
               b = dic.Item(dk)
               kq(b, 3) = kq(b, 3) & Chr(10) & arr(i, 3)
            End If
       Next i
    With Sheets("ketqua")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr > 1 Then .Range("A2:C" & lr).ClearContents
         If a Then .Range("A2:C2").Resize(a).Value = kq
    End With
    Set dic = Nothing
End Sub
Bạn thử cái này.
Nhấp chuột vào đây để mở rộng...
Cám ơn bác ạ!
 
Upvote 0
snow25 đã viết:
Tại bạn để như vậy trong file mẫu mà.
Mã: 
Sub gop()
Dim arr, i As Long, dic As Object, lr As Long, dk As Long, kq, b As Long, a As Long
Set dic = CreateObject("scripting.dictionary")
    With Sheets("file goc")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:C" & lr).Value2
         ReDim kq(1 To UBound(arr), 1 To 3)
    End With
        For i = 1 To UBound(arr)
            dk = arr(i, 2)
            If Not dic.exists(dk) Then
               a = a + 1
               kq(a, 1) = a
               kq(a, 2) = arr(i, 2)
               kq(a, 3) = arr(i, 3)
               dic.Add dk, a
            Else
               b = dic.Item(dk)
               kq(b, 3) = kq(b, 3) & Chr(10) & arr(i, 3)
            End If
       Next i
    With Sheets("ketqua")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr > 1 Then .Range("A2:C" & lr).ClearContents
         If a Then .Range("A2:C2").Resize(a).Value = kq
    End With
    Set dic = Nothing
End Sub
Bạn thử cái này.
Nhấp chuột vào đây để mở rộng...
Em chỉ muốn gộp cột B và C với nhau thôi mà không cần gộp cột số thứ tự thì làm như nào ạ,? Em thử chỉnh code của bác mà ko được! Cám ơn bác trước ạ!
 
Upvote 0
pingping2288 đã viết:
Em chỉ muốn gộp cột B và C với nhau thôi mà không cần gộp cột số thứ tự thì làm như nào ạ,? Em thử chỉnh code của bác mà ko được! Cám ơn bác trước ạ!
Nhấp chuột vào đây để mở rộng...
Bạn xóa dòng này


Mã: 
Sub gop()
Dim arr, i As Long, dic As Object, lr As Long, dk As Long, kq, b As Long, a As Long
Set dic = CreateObject("scripting.dictionary")
    With Sheets("file goc")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:C" & lr).Value2
         ReDim kq(1 To UBound(arr), 1 To 3)
    End With
        For i = 1 To UBound(arr)
            dk = arr(i, 2)
            If Not dic.exists(dk) Then
               a = a + 1
               kq(a, 1) = a ' xóa dòng này'
               kq(a, 2) = arr(i, 2)
               kq(a, 3) = arr(i, 3)
               dic.Add dk, a
            Else
               b = dic.Item(dk)
               kq(b, 3) = kq(b, 3) & Chr(10) & arr(i, 3)
            End If
       Next i
    With Sheets("ketqua")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr > 1 Then .Range("A2:C" & lr).ClearContents
         If a Then .Range("A2:C2").Resize(a).Value = kq
    End With
    Set dic = Nothing
End Sub
 
Upvote 0
LamNA đã viết:
Bạn xóa dòng này


Mã: 
Sub gop()
Dim arr, i As Long, dic As Object, lr As Long, dk As Long, kq, b As Long, a As Long
Set dic = CreateObject("scripting.dictionary")
    With Sheets("file goc")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:C" & lr).Value2
         ReDim kq(1 To UBound(arr), 1 To 3)
    End With
        For i = 1 To UBound(arr)
            dk = arr(i, 2)
            If Not dic.exists(dk) Then
               a = a + 1
               kq(a, 1) = a ' xóa dòng này'
               kq(a, 2) = arr(i, 2)
               kq(a, 3) = arr(i, 3)
               dic.Add dk, a
            Else
               b = dic.Item(dk)
               kq(b, 3) = kq(b, 3) & Chr(10) & arr(i, 3)
            End If
       Next i
    With Sheets("ketqua")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr > 1 Then .Range("A2:C" & lr).ClearContents
         If a Then .Range("A2:C2").Resize(a).Value = kq
    End With
    Set dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Không được anh ạ!
 
Upvote 0
Xài macro này thử trên file #10:
PHP: 
Sub GopTheoThoiGian()
Dim Rws As Long, W As Integer, J As Long, Dat As Date
Dim Arr()

With Sheets("file goc")
    Rws = .[B2].CurrentRegion.Rows.Count
    Arr() = .[B2].Resize(Rws, 2).Value:                       ReDim dArr(1 To Rws, 1 To 3)
    Sheets("KetQua").[A1].Resize(Rws, 3).Value = dArr()
    W = 1:                                                     dArr(W, 1) = .[A1].Value
    dArr(W, 2) = .[B1].Value:                                  dArr(W, 3) = .[C1].Value
End With
For J = 1 To UBound(Arr())
    If Arr(J, 1) = "" Then Exit For                            'Thoát Khi Hêt Du Liêu  '
    If Arr(J, 1) <> Dat Then
        W = W + 1:                                              dArr(W, 1) = W - 1
        dArr(W, 2) = Arr(J, 1):                                 dArr(W, 3) = Arr(J, 2)
        Dat = Arr(J, 1)
    Else
        dArr(W, 3) = dArr(W, 3) & Chr(10) & Arr(J, 2)
    End If
Next J
Sheets("KetQua").[A1].Resize(W, 3).Value = dArr()
End Sub
 
Lần chỉnh sửa cuối:
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

S
  • Question Question
Điều chỉnh kích thước dòng tự động theo trang in
Trả lời
5
Đọc
102
HUONGHCKT
H
A
Tạo vé Loto bằng Excel
2
Trả lời
20
Đọc
23K
Tuấn tata
Tuấn tata
T
File quản lý thiết bị trong trường học!
Trả lời
3
Đọc
69
SA_DQ
SA_DQ
Nauduong
Cách chuyển định dạng từ PDF sang Image
Trả lời
9
Đọc
222
Châu Bá Thông
Châu Bá Thông
minhduongct
  • Question Question
Viết code VBA thay cho dùng hàm vlookup
Trả lời
6
Đọc
1K
VetMini
V
N
Thử viết code lập trình đa luồng bằng TwinBasic và khả năng ứng dụng vào COM add-in chạy trong Excel
    • Thích
Trả lời
0
Đọc
88
nguyendang95
N
Momominh
Sơ đồ hàng hóa trong Container
Trả lời
1
Đọc
49
tranhungdao12a3
T
Thanh271188
Tìm giá trị xuất hiện bất kì (không phải giá trị đầu, cuối) trong excel
    • Cười
Trả lời
4
Đọc
207
Duy Tùng 9x
Duy Tùng 9x
H
Xin viết dùng mã vba thay thế cho hàm vlookup
    • Thích
12 13 14
Trả lời
264
Đọc
79K
VetMini
V
SA_DQ
  • Question Question
[Bài tập VBA cho người rỗi rảnh] Hãy viết 1 macro tìm ra 3 số nguyên tố liên tiếp
2
Trả lời
35
Đọc
730
VetMini
V
P
Các Bác cho e hỏi làm thế nào để ẩn công thức trên GOOGLE SHEET với ạ?
2
Trả lời
22
Đọc
18K
yeudoi
yeudoi
T
Định dạng cột dữ liệu trong sql
Trả lời
5
Đọc
129
ptm0412
ptm0412
L
  • Question Question
[Hlep] Xóa ảnh theo tên và kích thước
Trả lời
8
Đọc
188
Luong24
L
Xoainon3005
Xin file mẫu kế hoạch sản xuất theo tháng ngành động cơ
Trả lời
0
Đọc
89
Xoainon3005
Xoainon3005
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
14 15 16
Trả lời
308
Đọc
22K
CheezeTube
CheezeTube
HeSanbi
  • Đã giải quyết
LocalizeXL v1.73 - Làm nổi bật ô đang chọn và cuộn trang tự động
    • Thích
    • Yêu thích
2 3 4
Trả lời
74
Đọc
10K
vn72259
V
H
Vì sao trong khi cộng và khi sum lại hiển thị sai
Trả lời
15
Đọc
57K
hieung99
hieung99
T
Nhờ hỗ trợ hàm SUMIF không phân biệt được các ký tự "0" trước một số trong chuỗi
Trả lời
3
Đọc
212
tan10ckn
T
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Chấp nhận
2 3
Trả lời
46
Đọc
14K
tuantran203
T
ongke0711
  • Question Question
Trộn dữ liệu từ Excel sang Word mở rộng (phiên bản ongke0711)
    • Thích
    • Yêu thích
    • Cảm ơn
12 13 14
Trả lời
260
Đọc
27K
hoangtuan.net
hoangtuan.net
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
Chúc mừng năm mới Ất Tỵ 2025
Back
Top Bottom