Excel VBA技术求助：拆分含Alt+Enter换行的单元格内容并去重

原代码的问题分析 #

• 普通按钮宏里不能用Target，这是工作表事件（比如Worksheet_Change）专属对象，普通模块中未定义会直接报错。
• Split函数语法错误：函数名和参数之间不能有空格，参数分隔要用逗号，正确写法是Split(cell.Value, vbLf)，原代码里的worksheets("sheet1").cell.value.vbLf完全不符合语法。
• 写入B列时逻辑错误：每个单元格拆分后都从B1开始覆盖写入，没有延续到已有内容的下一行。
• 缺少去重处理逻辑。

修正后的实现方案 #

下面的代码会遍历A列所有非空单元格，拆分每个单元格里的换行内容，追加到B列，同时自动去除重复项：

Sub SplitAndRemoveDuplicates()
    Dim ws As Worksheet
    Dim lastRowA As Long, lastRowB As Long
    Dim cell As Range
    Dim splitArr As Variant
    Dim i As Long
    Dim isDuplicate As Boolean
    
    ' 指定操作的工作表
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    ' 获取A列最后一行（解决范围终点不确定的问题）
    lastRowA = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历A列每个非空单元格
    For Each cell In ws.Range("A1:A" & lastRowA)
        If cell.Value <> "" Then
            ' 按Alt+Enter的换行符(vbLf)拆分内容
            splitArr = Split(cell.Value, vbLf)
            
            ' 遍历拆分后的每一项
            For i = LBound(splitArr) To UBound(splitArr)
                ' 先检查是否重复
                isDuplicate = False
                lastRowB = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
                If lastRowB >= 1 Then
                    ' 遍历B列已有内容判断重复
                    For Each bCell In ws.Range("B1:B" & lastRowB)
                        If Trim(bCell.Value) = Trim(splitArr(i)) Then
                            isDuplicate = True
                            Exit For
                        End If
                    Next bCell
                End If
                
                ' 非重复则写入B列
                If Not isDuplicate Then
                    ws.Cells(ws.Rows.Count, "B").End(xlUp).Offset(1, 0).Value = Trim(splitArr(i))
                End If
            Next i
        End If
    Next cell
End Sub

代码说明 #

• 自动获取A列最后一行，适配不确定的单元格范围。
• 用Split(cell.Value, vbLf)准确拆分Alt+Enter产生的换行内容。
• 每次写入前遍历B列已有内容判断重复，确保B列无重复项。
• 用Trim()去除内容前后空格，避免因空格导致的伪重复。

替代方案（用Do Until循环遍历A列） #

如果偏好Do Until循环，也可以这样实现：

Sub SplitWithDoUntil()
    Dim ws As Worksheet
    Dim rowNumA As Long, lastRowB As Long
    Dim splitArr As Variant
    Dim i As Long
    Dim isDuplicate As Boolean
    
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    rowNumA = 1
    
    Do Until ws.Cells(rowNumA, "A").Value = ""
        ' 拆分内容
        splitArr = Split(ws.Cells(rowNumA, "A").Value, vbLf)
        
        For i = LBound(splitArr) To UBound(splitArr)
            isDuplicate = False
            lastRowB = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
            
            If lastRowB >= 1 Then
                For Each bCell In ws.Range("B1:B" & lastRowB)
                    If Trim(bCell.Value) = Trim(splitArr(i)) Then
                        isDuplicate = True
                        Exit For
                    End If
                Next bCell
            End If
            
            If Not isDuplicate Then
                ws.Cells(lastRowB + 1, "B").Value = Trim(splitArr(i))
            End If
        Next i
        
        rowNumA = rowNumA + 1
    Loop
End Sub

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