求编写Excel宏：选中行邮箱地址转置为分号分隔格式

以下是两个VBA宏，分别实现你需要的两种邮箱处理功能：

1. 将选中行的邮箱合并为单个分号分隔的单元格 #

这个宏会遍历选中行的所有单元格，提取邮箱地址，合并到指定的单个单元格中，用分号分隔。

Sub MergeEmailsToSingleCell()
    Dim selectedRow As Range
    Dim cell As Range
    Dim emailList As String
    Dim outputCell As Range
    
    ' 校验选中范围是否为单行
    If TypeName(Selection) <> "Range" Or Selection.Rows.Count <> 1 Then
        MsgBox "请选中单个目标行！", vbExclamation
        Exit Sub
    End If
    
    Set selectedRow = Selection.EntireRow
    
    ' 遍历行内单元格，收集有效邮箱
    For Each cell In selectedRow.Cells
        ' 简单判断邮箱格式（非空且包含@）
        If cell.Value <> "" And InStr(1, cell.Value, "@", vbTextCompare) > 0 Then
            If emailList <> "" Then emailList = emailList & "; "
            emailList = emailList & Trim(cell.Value)
        End If
    Next cell
    
    ' 让用户选择输出单元格
    On Error Resume Next
    Set outputCell = Application.InputBox("选择输出合并后邮箱的单元格", Type:=8)
    On Error GoTo 0
    
    If outputCell Is Nothing Then Exit Sub
    
    ' 写入结果
    outputCell.Value = emailList
    MsgBox "邮箱合并完成！", vbInformation
End Sub

2. 将选中行的邮箱转置为一列（每个邮箱单独一行） #

这个宏会提取选中行的邮箱，拆分后转置到你指定的起始单元格所在的列，每个邮箱占一行。

Sub TransposeEmailsToColumn()
    Dim selectedRow As Range
    Dim cell As Range
    Dim emailArr() As String
    Dim emailList As String
    Dim outputRange As Range
    Dim i As Integer
    
    ' 校验选中范围是否为单行
    If TypeName(Selection) <> "Range" Or Selection.Rows.Count <> 1 Then
        MsgBox "请选中单个目标行！", vbExclamation
        Exit Sub
    End If
    
    Set selectedRow = Selection.EntireRow
    
    ' 收集有效邮箱
    For Each cell In selectedRow.Cells
        If cell.Value <> "" And InStr(1, cell.Value, "@", vbTextCompare) > 0 Then
            If emailList <> "" Then emailList = emailList & "; "
            emailList = emailList & Trim(cell.Value)
        End If
    Next cell
    
    ' 拆分邮箱为数组
    If emailList = "" Then
        MsgBox "未找到任何邮箱地址！", vbExclamation
        Exit Sub
    End If
    emailArr = Split(emailList, "; ")
    
    ' 让用户选择输出起始单元格
    On Error Resume Next
    Set outputRange = Application.InputBox("选择输出列的起始单元格", Type:=8)
    On Error GoTo 0
    
    If outputRange Is Nothing Then Exit Sub
    
    ' 转置输出到列
    For i = LBound(emailArr) To UBound(emailArr)
        outputRange.Offset(i, 0).Value = emailArr(i)
    Next i
    
    MsgBox "邮箱转置为一列完成！", vbInformation
End Sub

使用步骤 #

1. 打开你的联系人列表Excel文件，按下Alt + F11打开VBA编辑器
2. 在左侧工程窗口中，右键点击你的工作簿名称，选择「插入」→「模块」
3. 将上述两个宏的代码粘贴到新模块中
4. 返回Excel界面，选中包含邮箱的目标行
5. 按下Alt + F8，选择需要执行的宏（MergeEmailsToSingleCell或TransposeEmailsToColumn），点击「执行」
6. 根据提示选择输出位置即可完成操作

可选优化：精确邮箱格式验证 #

如果需要更严格的邮箱格式校验，可以替换宏中的邮箱判断逻辑为正则表达式验证：

' 在宏开头添加正则对象声明
Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")
regex.Pattern = "^[a-zA-Z0-9._%+-]+@[a-zA-Z0-9.-]+\.[a-zA-Z]{2,}$"
regex.IgnoreCase = True

' 替换原有的邮箱判断条件
If cell.Value <> "" And regex.Test(cell.Value) Then
    ' 收集邮箱的代码不变
End If

内容的提问来源于stack exchange，提问作者Abhijit Biswas