Tách riêng từng email trong một ô excel

Chia sẻ bởi:hands

★★★★★

‹ Giúp về gộp nhóm và sắp xếp... Câu lệnh UPDATE trong SQL ›

Quảng cáo

Chào mọi người,

Em đang có một file dữ liệu, trong 1 ô có rất nhiều email cách nhau cách nhau bằng một dấu ";".
Có cách nào để mình tách riêng ra từng cột cho những email này không? Em đang cần dùng mail merge để gừi mail .

Cảm ơn mọi người.

Giả sử cột dữ liệu của bạn như trong file

Chạy code này, sau đó dùng chức năng Text to Columns để xử lý

Sub thay_ky_tu()
With Range(, .End(3))
.Replace ChrW(10), ";"
.Replace "-", ";"
.Replace "/", ";"
.Replace ",", ";"
.Replace ":", ";"
End With
End Sub

Với file bạn dùng text to column ở bước cuối cùng bạn check toàn bộ và other thì đánh dấu ; sau đó dùng Ctrl + H thay thế mấy ký tự kia, hoặc dùng code của bạn quanghai

Cái chuỗi chrw(10) có tìm và thay được không? Mình đã cố thử nhưng không thay được cái (Alt + Enter)

Thì quanghai nhấn Alt + 010 bên phím số là được mà Uronmapu làm được chưa vậy nếu không được đưa file chính thức của bạn lên nhen

Nếu đã xài code thì xài code tất tần tật cho rồi.

Sub tach_email()
Dim dl, tachra, kq()
Dim n As Byte, i As Long, j As Byte
With Range(, .End(3))
.Replace ChrW(10), ";"
.Replace "-", ";": .Replace "/", ";"
.Replace ",", ";": .Replace ":", ";"
End With
dl = Range(, .End(3))
For i = 1 To UBound(dl)
tachra = Split(dl(i, 1), ";")
If UBound(tachra) > n Then n = UBound(tachra)
ReDim Preserve kq(1 To UBound(dl, 1), 1 To n + 1)
For j = 0 To UBound(tachra)
kq(i, j + 1) = Trim(tachra(j))
Next
Next
.Resize(i – 1, n + 1) = kq
End Sub

Cảm ơn bác quanghai lần nữa, nhưng bác làm là tách ra các cột khác nhau

Em muốn nó tách xuống hàng tiếp theo thì có làm được ko ạ

Nghĩa là 2 email trên 1 dòng nó sẽ tách thành 2 dòng (mỗi email trên 1 dòng) chứ ko phải tách làm 2 cột như trong ví dụ bác làm

Xin bác giúp em

Bạn thay code này vào sẽ được

Sub tach_email()
Dim dic As Object
Dim dl, tachra
Dim i As Long, j As Byte
Set dic = CreateObject("scripting.dictionary")
With Range(, .End(3))
.Replace ChrW(10), ";"
.Replace "-", ";": .Replace "/", ";"
.Replace ",", ";": .Replace ":", ";"
End With
dl = Range(, .End(3))
For i = 1 To UBound(dl)
tachra = Split(dl(i, 1), ";")
For j = 0 To UBound(tachra)
If Not dic.exists(Trim(tachra(j))) Then
dic.Add Trim(tachra(j)), ""
End If
Next
Next
.Resize(dic.Count) = Application.Transpose(dic.keys)
End Sub

www.giaiphapexcel.com/diendan/threads/t%C3%A1ch-ri%C3%AAng-t%E1%BB%ABng-email-trong-m%E1%BB%99t-%C3%B4-excel.69152/

Khóa học SprinGO phù hợp

Xây dựng Lương 3P, KPI cho Doanh nghiệp

Làm thế nào để trả lương cho nhân viên chính xác nhất? Đây là một trong những câu hỏi khó trong quản trị nhân...

Xem khóa học

★★★★★ 5 ★ 1 👤 1 ▥ 0

‹ Giúp về gộp nhóm và sắp xếp SQL... Câu lệnh UPDATE trong SQL ›

Quảng cáo

Bạn nên đọc

Tìm ngày giờ kết thúc dự kiến

Tổng hợp file Excel tính giá thành sản phẩm cho doanh nghiệp sản xuất, gia công, xây lắp

Hướng dẫn xử lý file Excel chậm

Công thức quy đổi lương NET sang GROSS

Tính thưởng lũy tiến

Cách tách chuỗi trong dấu ngoặc Excel bằng công thức và Flash Fill

One Response

hands says:

01/02/2023 at 9:14 am

Thêm cách không dùng vòng lặp:

Public Sub TachEmail()
    Dim Vung As Range, Tach, Gom As String
    Set Vung = Range([A2], [A10000].End(xlUp))
    Gom = Join(Application.WorksheetFunction.Transpose(Vung), ";")
    Gom = Replace(Gom, " ", ""): Gom = Replace(Gom, ";", " "): Gom = Replace(Gom, ":", " ")
    Gom = Replace(Gom, ",", " "): Gom = Replace(Gom, "-", " "): Gom = Replace(Gom, "/", " "): Gom = Replace(Gom, Chr(10), " ")
        Tach = Split(Gom)
    [B2:B10000].ClearContents
    [B2].Resize(UBound(Tach) + 1) = Application.WorksheetFunction.Transpose(Tach)
End Sub

Hoặc:

Public Sub TachEmail123()
    Dim Vung As Range, Tach, Gom As String, Re
    Set Re = CreateObject("vbscript.regexp")
    Set Vung = Range([A2], [A10000].End(xlUp))
    Gom = Join(Application.WorksheetFunction.Transpose(Vung), ";"): Gom = Replace(Gom, " ", "")
            With Re
                .Global = True
                .IgnoreCase = True
                .Pattern = ";|,|/|n|:|-"
                Gom = .Replace(Gom, " ")
           End With
        Tach = Split(Gom)
    [B2:B10000].ClearContents
    [B2].Resize(UBound(Tach) + 1) = Application.WorksheetFunction.Transpose(Tach)
End Sub

Thân

Xin hỏi các bác là thêm trường hợp email có kiểu như bên dưới thì làm sao ạ

uron@yahoo.com matmetide@gmail.com (có dấu cách)

uron@yahoo.com/ matmetide@gmail.com (gạch và dấu cách)

uron@yahoo.com: matmetide@gmail.com (hai chấm và cách)

uron@yahoo.com or matmetide@gmail.com (cách or và cách)

Bạn xem nghiên cứu cái này, có ký tự nào phát sinh thì cứ thêm vào sẽ tách được

Sub Tach_email()
With
.Replace "/", ";" 'Chuyen dấu / thành dấu ;
.Replace "or", ";" 'chuyển chữ or thành dấu ;
.Replace " ", ";" 'chuyển 2 dấu cách liên tiếp nếu có thành dấu ;
.TextToColumns , Semicolon:=True, Comma:=True, _
Space:=True, OtherChar:=":"
End With
End Sub

Xin chào,
Mình đang dùng đoạn code bên dưới để tách email

Sub tach_email()
Dim dic As Object
Dim dl, tachra
Dim i As Long, j As Byte
Set dic = CreateObject("scripting.dictionary")
  With Range([B2], [B65536].End(3))
    .Replace ChrW(10), ";"
      .Replace "-", ";":    .Replace "/", ";"
        .Replace ",", ";":    .Replace ":", ";"
          End With
dl = Range([B2], [B65536].End(3))
  For i = 1 To UBound(dl)
    tachra = Split(dl(i, 1), ";")
      For j = 0 To UBound(tachra)
        If Not dic.exists(Trim(tachra(j))) Then
          dic.Add Trim(tachra(j)), ""
        End If
      Next
  Next
[c2].Resize(dic.Count) = Application.Transpose(dic.keys)
End Sub

Nhưng với 65000 bản ghi (65000 hàng) thì khi tách báo lỗi

Run-time error '13'
Type mismatch

Tại dòng: .Resize(dic.Count) = Application.Transpose(dic.keys)