Question

我需要Excel为来自所有单元格的电子邮件创建新行，其中多个电子邮件由逗号分隔，并将每封电子邮件放入新行（不带逗号）。 Example

我该怎么做？我对Excel和VBA都很陌生。

Answer 1

你可以使用＆＃34;文本到列＆＃34;。您可以在数据下的功能区中找到它。然后设置＆＃39;，＆＃39;作为分隔符，每个电子邮件地址都将在新列中。

Answer 2

试试这个例子：

Public Sub ExpandEmails()
    Dim r As Range
    Set r = [A1]

    Const COLS = 3 ' Assume table has 3 columns only

    Dim i As Long, j As Long, N As Long, k As Long, M As Long
    'Count rows in table and make range include all rows and columns
    N = CountRows(r)
    Set r = r.Resize(N, COLS)

    'Transfer values from Excel to VBA array 'vals'
    Dim vals() As Variant
    vals = r.Value

    'Count all emails to allocate a new array, M
    k = 0
    For i = 1 To N
        k = k + CountInstances(vals(i, COLS), ",") + 1
    Next i
    M = k
    ' For each row expand out the emails
    Dim list() As Variant, items() As String
    ReDim list(1 To M, 1 To COLS)
    k = 1
    For i = 1 To N
        'Copy other values in columns
        For j = 1 To COLS - 1
            list(k, j) = vals(i, j)
        Next j
        ' Copy email list in rows
        items = SplitAtTokens(vals(i, COLS), ",")
        For j = 0 To UBound(items, 1)
            list(k + j, COLS) = items(j)
        Next j
        k = k + j
    Next i

    'Resize output range and export new table
    [J1].Resize(M, COLS).Value = list
End Sub

' Enumerate non-empty cells down the rows.
Public Function CountRows(ByRef r As Range) As Long
    If IsEmpty(r) Then
        CountRows = 0
    ElseIf IsEmpty(r.Offset(1, 0)) Then
        CountRows = 1
    Else
        CountRows = r.Worksheet.Range(r, r.End(xlDown)).Rows.Count
    End If
End Function

' Split a string by returning the left part and modifying the argument 'str'
' by trimming at the token
Function SplitAt(ByRef str As String, ByVal at As Integer) As String
    SplitAt = Left(str, at)
    str = Mid(str, at + 1)
End Function

' Counts instances of token character in string.
Function CountInstances(ByVal data As String, ByVal tok As String) As Integer
    Dim res As Long, pos As Long
    res = 0
    pos = 0
    Do
        pos = InStr(pos + 1, data, tok, vbTextCompare)
        res = res + 1
    Loop Until pos = 0
    CountInstances = res - 1
End Function

' Splits a string into an array of strings at each token character.
Function SplitAtTokens(ByVal data As String, ByVal tok As String) As String()
    Dim pos As Long, i As Long, num_of_lines As Long, next_token As Long
    Dim res() As String
    If Not data = vbNullString Then
        num_of_lines = CountInstances(data, tok) + 1
        ReDim res(num_of_lines - 1) As String
        For i = 1 To num_of_lines
            pos = InStr(1, data, tok, vbTextCompare)
            If pos > 0 Then
                res(i - 1) = SplitAt(data, pos - 1)
                data = Right(data, Len(data) - Len(tok))
            Else
                res(i - 1) = data
                data = ""
            End If
        Next i
    End If
    SplitAtTokens = res
End Function

Result

您必须针对列数和输入/输出范围进行调整，但逻辑完整无缺。

Excel添加包含数据的行

2 个答案: