求助：使用VBA合并多行数据且不丢失信息（现有代码无效）

我有一组数据集，需要用VBA将同一标识（G列）的多行数据合并为一行且不丢失信息。之前试过不同代码，结果只保留了首行信息；现在用了下面这段MergeRows代码，运行后完全没有效果，求帮忙解决。

我使用的代码 #

Sub MergeRows()

    Dim ws As Worksheet
    Dim i As Long, j As Long, lastRow As Long
    Dim target As String

    'Set the worksheet
    Set ws = ThisWorkbook.Sheets("Sheet 1")

    'Find the last row
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    'Loop through each row (except the first one)
    For i = 2 To lastRow
        'Set the target column value
        target = ws.Cells(i, "G").Value

        'Loop backwards from the current row to the first row
        For j = i To 2 Step -1
            'Check if the target column value is the same as in the current row
            If ws.Cells(j, "G").Value = target Then
                'If the target column value is the same, concatenate the values of the other columns
                ws.Cells(i, "C").Value = ws.Cells(i, "C").Value & ", " & ws.Cells(j, "C").Value
                ws.Cells(i, "D").Value = ws.Cells(i, "D").Value & ", " & ws.Cells(j, "D").Value
                'Delete the merged row
                ws.Rows(j).Delete
            End If
        Next j
    Next i
End Sub

代码问题分析 #

原代码核心逻辑错误导致无效果：

• 内层循环j从i开始，拿当前行和自己比对，必然相等，会重复拼接同一行内容后删除当前行，直接打乱后续循环索引
• 外层循环从上往下执行，删除行后未更新lastRow，导致后续循环处理已删除的行，逻辑彻底混乱

修正后的代码 #

Sub MergeRows_Fixed()
    Dim ws As Worksheet
    Dim i As Long, lastRow As Long
    Dim targetVal As String
    
    ' 指定目标工作表
    Set ws = ThisWorkbook.Sheets("Sheet 1")
    ' 获取G列最后一行行号（按标识列取更准确）
    lastRow = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
    
    ' 从最后一行往上循环，避免删除行后索引错乱
    For i = lastRow To 2 Step -1
        targetVal = ws.Cells(i, "G").Value
        ' 和上一行比对，若G列标识相同则合并
        If ws.Cells(i - 1, "G").Value = targetVal Then
            ' 合并C列，避免开头出现多余逗号
            If ws.Cells(i - 1, "C").Value <> "" Then
                ws.Cells(i - 1, "C").Value = ws.Cells(i - 1, "C").Value & ", " & ws.Cells(i, "C").Value
            Else
                ws.Cells(i - 1, "C").Value = ws.Cells(i, "C").Value
            End If
            ' 合并D列，同理处理逗号问题
            If ws.Cells(i - 1, "D").Value <> "" Then
                ws.Cells(i - 1, "D").Value = ws.Cells(i - 1, "D").Value & ", " & ws.Cells(i, "D").Value
            Else
                ws.Cells(i - 1, "D").Value = ws.Cells(i, "D").Value
            End If
            ' 删除当前重复行
            ws.Rows(i).Delete
        End If
    Next i
End Sub

使用说明 #

• 确保同一标识（G列）的行是连续排列的，若不连续，建议先按G列排序再运行代码
• 运行前请备份数据，避免误操作
• 若需要合并其他列，参照C、D列的写法补充即可

内容的提问来源于stack exchange，提问作者Silvia González