VBA实现多列联系人数据转多行的技术求助（新手）

我是VBA新手，现有包含1000余家企业的数据集，每个企业条目下设有多列联系人信息。希望编写VBA脚本，将每个联系人单独生成一行，同时保留对应企业的名称及相关数据。目前仅写出部分代码片段，尚未完成，不知后续如何推进。

数据格式示例 #

原表 #

目标表 #

现有代码片段 #

Dim cr As Long '当前行
Dim cc As Long '当前列

For cr = 2 To Cells(Rows.Count, "A").End(xlUp).Row
   For cc = 5 To Cells(Columns.Count, "?") 

完整实现代码 #

下面是补全后的完整VBA代码，注释标注了关键步骤，适合新手理解：

Sub SplitContactsToRows()
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim cr As Long '原表当前行
    Dim cc As Long '原表当前联系人列
    Dim targetRow As Long '目标表写入行
    
    '指定源工作表和目标工作表，可根据实际名称修改
    Set wsSource = ThisWorkbook.Worksheets("Sheet1")
    Set wsTarget = ThisWorkbook.Worksheets("Sheet2")
    
    '初始化目标表数据起始行（跳过表头）
    targetRow = 2
    
    '复制源表表头到目标表
    wsSource.Rows(1).Copy wsTarget.Rows(1)
    '调整目标表第三列表头为"联系人"
    wsTarget.Cells(1, 3).Value = "联系人"
    
    '遍历源表所有企业行（从第2行开始，跳过表头）
    For cr = 2 To wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
        '遍历当前企业的所有联系人列，自动定位到最后一列有数据的单元格
        For cc = 3 To wsSource.Cells(cr, wsSource.Columns.Count).End(xlToLeft).Column
            '跳过空的联系人单元格
            If wsSource.Cells(cr, cc).Value <> "" Then
                '写入企业名称和相关数据
                wsTarget.Cells(targetRow, 1).Value = wsSource.Cells(cr, 1).Value
                wsTarget.Cells(targetRow, 2).Value = wsSource.Cells(cr, 2).Value
                '写入单个联系人
                wsTarget.Cells(targetRow, 3).Value = wsSource.Cells(cr, cc).Value
                '目标行下移，准备写入下一条数据
                targetRow = targetRow + 1
            End If
        Next cc
    Next cr
    
    MsgBox "数据拆分完成！"
End Sub

使用说明 #

1. 提前确认源表（Sheet1）和目标表（Sheet2）的名称与实际一致，不一致则修改代码中的工作表名称
2. 代码默认从第3列开始是联系人列，如果你的数据中联系人列从第5列开始，把cc = 3改成cc = 5即可
3. 运行前建议备份原始数据，避免误操作

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