Nhờ hướng dẫn cách viết code chia nhóm có điều kiện

Liên hệ QC

Vocamthuy

Thành viên mới
Tham gia
8/1/20
Bài viết
8
Được thích
0
Xin chào các anh chị !
Em mới làm quen với VBA nên còn nhiều điều chưa nắm rõ, mong nhận được sự chỉ giáo, giúp đỡ từ các anh chị.
Em có file tổng hợp hơn 70.000 email, cần chia thành từng nhóm. Điều kiện như sau:
- Mỗi nhóm có 1.000 email (Cột B)
- Trong 1 nhóm không được trùng địa chỉ của đuôi mail (Cột A)
- Sau khi chia xong thì điền số thứ tự của nhóm vào Cột M

Rất mong nhận được sự giúp đỡ của các anh chị.
Em cảm ơn nhiều ạ !
 

File đính kèm

  • TONG HOP DS MAIL .xlsx
    4.4 MB · Đọc: 23
Xin chào các anh chị !
Em mới làm quen với VBA nên còn nhiều điều chưa nắm rõ, mong nhận được sự chỉ giáo, giúp đỡ từ các anh chị.
Em có file tổng hợp hơn 70.000 email, cần chia thành từng nhóm. Điều kiện như sau:
- Mỗi nhóm có 1.000 email (Cột B)
- Trong 1 nhóm không được trùng địa chỉ của đuôi mail (Cột A)
- Sau khi chia xong thì điền số thứ tự của nhóm vào Cột M

Rất mong nhận được sự giúp đỡ của các anh chị.
Em cảm ơn nhiều ạ !
Cho mình hỏi cái chỉ cần chia nhóm và điền vào cột M đúng không.Mà nó có trùng maile không.
 
Upvote 0
Mình đã lọc mail trùng rồi. Giờ cần chia nhóm theo 2 điều kiện như mình đã viết và điền tên nhóm vào cột M.
Bạn thử cái code ngu ngu này xem nhé.Chỗ cuối nó chia sao không đúng lắm.Để mình kiểm tra lại.
Mã:
Sub diennhom()
    Dim lr As Long, i As Long, arr, kq, dk As String, dks As String, dic As Object, b As Long, c As Long, a As Long, nhom As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("list tong")
         nhom = 1
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:B" & lr).Value
         ReDim kq(1 To UBound(arr), 1 To 1)
         Do
         For i = 1 To UBound(arr)
          If kq(i, 1) = Empty Then
             dk = arr(i, 1)
             dks = arr(i, 2)
             If Not dic.exists(dk) Then
                b = b + 1
                a = a + 1
                If a = 1001 Then a = 1: nhom = nhom + 1
                kq(i, 1) = nhom
                dic.Add dk, Array(a, 1)
             End If
          End If
       Next i
       dic.RemoveAll
       Loop Until b = UBound(arr)
       .Range("m2:m" & lr).Value = kq
   End With
End Sub
 
Upvote 0
Bạn thử cái code ngu ngu này xem nhé.Chỗ cuối nó chia sao không đúng lắm.Để mình kiểm tra lại.
Mã:
Sub diennhom()
    Dim lr As Long, i As Long, arr, kq, dk As String, dks As String, dic As Object, b As Long, c As Long, a As Long, nhom As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("list tong")
         nhom = 1
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:B" & lr).Value
         ReDim kq(1 To UBound(arr), 1 To 1)
         Do
         For i = 1 To UBound(arr)
          If kq(i, 1) = Empty Then
             dk = arr(i, 1)
             dks = arr(i, 2)
             If Not dic.exists(dk) Then
                b = b + 1
                a = a + 1
                If a = 1001 Then a = 1: nhom = nhom + 1
                kq(i, 1) = nhom
                dic.Add dk, Array(a, 1)
             End If
          End If
       Next i
       dic.RemoveAll
       Loop Until b = UBound(arr)
       .Range("m2:m" & lr).Value = kq
   End With
End Sub
Cảm ơn bạn đã giúp đỡ nha ! :)
 
Upvote 0
- Mỗi nhóm có 1.000 email (Cột B)
- Trong 1 nhóm không được trùng địa chỉ của đuôi mail (Cột A)
- Sau khi chia xong thì điền số thứ tự của nhóm vào Cột M
Mỗi nhóm không được trùng cột A, như vậy có thể có nhóm không đủ 1000, thậm chí chỉ có 1 dữ liệu cột A.
 
Upvote 0
Mỗi nhóm không được trùng cột A, như vậy có thể có nhóm không đủ 1000, thậm chí chỉ có 1 dữ liệu cột A.
Dạ đúng vậy, những nhóm đầu chia đúng cả 2 điều kiện, nhưng nhóm cuối nếu muốn đủ 1000 mail thì chắc chắn bị trùng cột A hoặc muốn không bị trùng thì sẽ không đủ 1000 mail.
Dữ liệu của em cũng ko đc chuẩn xác nên theo code bạn Snow25 hướng dẫn, kết quả vượt quá mong đợi của em rồi.
Cảm ơn anh chị rất nhiều ạ !
 
Upvote 0
Bạn thử cái code ngu ngu này xem nhé.Chỗ cuối nó chia sao không đúng lắm.Để mình kiểm tra lại.
Mã:
Sub diennhom()
    Dim lr As Long, i As Long, arr, kq, dk As String, dks As String, dic As Object, b As Long, c As Long, a As Long, nhom As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("list tong")
         nhom = 1
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:B" & lr).Value
         ReDim kq(1 To UBound(arr), 1 To 1)
         Do
         For i = 1 To UBound(arr)
          If kq(i, 1) = Empty Then
             dk = arr(i, 1)
             dks = arr(i, 2)
             If Not dic.exists(dk) Then
                b = b + 1
                a = a + 1
                If a = 1001 Then a = 1: nhom = nhom + 1
                kq(i, 1) = nhom
                dic.Add dk, Array(a, 1)
             End If
          End If
       Next i
       dic.RemoveAll
       Loop Until b = UBound(arr)
       .Range("m2:m" & lr).Value = kq
   End With
End Sub
Bạn ơi cho mình hỏi, nếu mình sắp xếp những đuôi mail giống nhau (Cột A) thành từng nhóm rồi đánh số thứ tự "n" cho từng mail (Cột B) trong nhóm, sau đó điền số thứ tự "n" vào cột M, (lúc đó số "n" chính là số thứ tự của nhóm mà mình muốn chia, và ko cố định mỗi nhóm là 1000 mail nữa). Bạn có thể hướng dẫn mình code cho cách này được không ?
 
Upvote 0
Bạn ơi cho mình hỏi, nếu mình sắp xếp những đuôi mail giống nhau (Cột A) thành từng nhóm rồi đánh số thứ tự "n" cho từng mail (Cột B) trong nhóm, sau đó điền số thứ tự "n" vào cột M, (lúc đó số "n" chính là số thứ tự của nhóm mà mình muốn chia, và ko cố định mỗi nhóm là 1000 mail nữa). Bạn có thể hướng dẫn mình code cho cách này được không ?
Không hiểu lắm bạn cho ví dụ cụ thể xem nhé.
 
Upvote 0
View attachment 231003
Cột A: đuôi mail giống nhau thành 1 nhóm
Cột B: đánh số thứ tự cho mail trong nhóm đuôi mail trùng nhau và điền vào cột M
Sorry bạn nha :)
Bạn thử code này nhé.Không cần sắp xếp cũng được.
Mã:
Sub test()
   Dim arr, i As Long, dk As String, a As Long, dic As Object, kq, lr As Long
   Set dic = CreateObject("scripting.dictionary")
   With Sheets("list tong")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A2:A" & lr).Value
        ReDim kq(1 To UBound(arr), 1 To 1)
        For i = 1 To UBound(arr)
            dk = arr(i, 1)
            If Not dic.exists(dk) Then
               dic.Add dk, 1
               kq(i, 1) = 1
            Else
               a = dic.Item(dk) + 1
               kq(i, 1) = a
               dic.Item(dk) = a
            End If
        Next i
        .Range("m2:m" & lr).Value = kq
 End With
End Sub
 
Upvote 0
Bạn thử code này nhé.Không cần sắp xếp cũng được.
Mã:
Sub test()
   Dim arr, i As Long, dk As String, a As Long, dic As Object, kq, lr As Long
   Set dic = CreateObject("scripting.dictionary")
   With Sheets("list tong")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A2:A" & lr).Value
        ReDim kq(1 To UBound(arr), 1 To 1)
        For i = 1 To UBound(arr)
            dk = arr(i, 1)
            If Not dic.exists(dk) Then
               dic.Add dk, 1
               kq(i, 1) = 1
            Else
               a = dic.Item(dk) + 1
               kq(i, 1) = a
               dic.Item(dk) = a
            End If
        Next i
        .Range("m2:m" & lr).Value = kq
End With
End Sub
Ok, mình chạy được rồi. Cảm ơn bạn nhiều nha !
 
Upvote 0
Chia mail để làm gì?
Đây là bài toán khác mà đáo hình, hay là bài toán mail spam / hack email?
 
Lần chỉnh sửa cuối:
Upvote 0
Chia mail để làm gì?
Đây là bài toán khác mà đáo hình, hay là bài toán mail spam / hack email?
Dạ, vì em có plan gửi mail marketing cho khách hàng với điều kiện là gửi theo từng nhóm.
Danh sách mail đều là khách hàng của công ty, nhờ code sẽ hỗ trợ việc chia nhóm được nhanh và chuẩn xác hơn.
Cảm ơn anh/chị đã quan tâm và thẳng thắn đưa ra vấn đề.
Em chỉ suy nghĩ đơn giản là hỏi những điều mình còn thiếu kinh nghiệm và cũng rất mong được anh/chị giúp đỡ.
 
Upvote 0
Web KT
Back
Top Bottom