Excel VBA：按条件将数据复制到指定行的下一个空白单元格

问题根源 #

现有代码的核心问题是：匹配到客户参考号后，固定写入第5列（E列），没有动态定位当前行的下一个可用空列，所以每次都会覆盖原有数据，不会向后追加。

修正后的完整代码 #

Sub 合并客户结果数据()
    Dim roughSht As Worksheet, finishSht As Worksheet
    Dim i As Long, n As Long, nextCol As Long
    Dim ref As String, check As String
    Dim done As Boolean
    
    ' 绑定工作表，避免频繁切换
    Set roughSht = ThisWorkbook.Sheets("Rough Data")
    Set finishSht = ThisWorkbook.Sheets("Finished Data")
    
    ' 复制A列并去重，保留原有逻辑
    roughSht.Columns("A:A").Copy finishSht.Columns("A:A")
    Application.CutCopyMode = False
    finishSht.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
    
    ' 遍历Rough Data的所有数据行
    i = 2
    Do While roughSht.Cells(i, 1).Value <> ""
        ref = roughSht.Cells(i, 1).Value
        n = 2
        done = False
        
        Do While done = False
            check = finishSht.Cells(n, 1).Value
            If check <> "" Then
                If check = ref Then
                    ' 动态查找当前行最右侧非空列的下一列，作为写入位置
                    nextCol = finishSht.Cells(n, finishSht.Columns.Count).End(xlToLeft).Column + 1
                    ' 写入D列结果
                    finishSht.Cells(n, nextCol).Value = roughSht.Cells(i, 4).Value
                    done = True
                End If
            Else
                ' 新客户编号，直接写入第一行空行，第一个结果写入B列
                finishSht.Cells(n, 1).Value = ref
                finishSht.Cells(n, 2).Value = roughSht.Cells(i, 4).Value
                done = True
            End If
            n = n + 1
        Loop
        
        i = i + 1
    Loop
End Sub

关键调整说明 #

• 直接绑定工作表对象，去掉了无意义的工作表切换、选中操作，运行速度更快，也避免屏幕闪烁
• 新增nextCol计算逻辑：Cells(n, Columns.Count).End(xlToLeft).Column会自动获取指定行最右侧有数据的列号，加1就是下一个可写入的空列，实现同客户多个结果自动向后追加
• 优化了空值判断逻辑，用<>""替代>0，兼容文本格式的客户参考号场景

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