Excel VBA实现多值列转单列 按行匹配分类跨表复制

需求场景 #

工作表字段包含：Company name、1st name、last name、number of units、unit 1、unit 2、unit 3、unit 4、family、email。原始数据在Sheet1中，每家公司占单独一行，部分公司同时关联多个unit，需要按所属unit拆分公司数据，将结果输出到Sheet2，每行对应单个公司+单个关联unit的组合。

• 原始数据效果：
  
• 目标输出效果：
  

注：表格内所有数据均为虚构测试数据。

原有代码问题 #

原有代码仅能实现同表列位置偏移，既无法将多列unit数据合并为单列输出，也未实现跨工作表的数据写入，代码如下：

Sub Button2_Click()

Dim cr As Long 'current row
Dim cc As Long 'current column

For cr = 2 To 11
    For cc = 8 To 11 Step 2
        If Cells(cr, cc).Value = "R" Then
            'make column 13 (M) in current row = unit
            Cells(cr, 13).Value = Cells(1, cc).Value
        End If
    Next
Next
End Sub

可直接运行的实现代码 #

替换原有按钮事件代码即可使用，代码会自动遍历原始数据、逐行判断关联unit、将拆分后的结果写入Sheet2：

Sub Button2_Click()
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim lastSourceRow As Long, outputRow As Long
    Dim cr As Long, cc As Long
    
    ' 绑定数据源表和结果输出表
    Set wsSource = ThisWorkbook.Worksheets("Sheet1")
    Set wsTarget = ThisWorkbook.Worksheets("Sheet2")
    
    ' 初始化结果表，写入表头
    wsTarget.Cells.Clear
    wsTarget.Range("A1:G1") = Array( _
        "Company name", "1st name", "last name", _
        "number of units", "family", "email", "Unit" _
    )
    outputRow = 2
    
    ' 获取原始表最后一条数据的行号
    lastSourceRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    
    ' 逐行遍历原始公司数据
    For cr = 2 To lastSourceRow
        ' 遍历所有unit标记列，匹配原有代码的列范围（8-11列，步长2）
        For cc = 8 To 11 Step 2
            ' 按原有逻辑，标记值为"R"代表当前公司关联该列对应的unit
            If wsSource.Cells(cr, cc).Value = "R" Then
                ' 写入公司基础信息
                wsTarget.Cells(outputRow, "A") = wsSource.Cells(cr, "A")
                wsTarget.Cells(outputRow, "B") = wsSource.Cells(cr, "B")
                wsTarget.Cells(outputRow, "C") = wsSource.Cells(cr, "C")
                wsTarget.Cells(outputRow, "D") = wsSource.Cells(cr, "D")
                wsTarget.Cells(outputRow, "E") = wsSource.Cells(cr, "I")
                wsTarget.Cells(outputRow, "F") = wsSource.Cells(cr, "J")
                ' 写入关联的unit名称
                wsTarget.Cells(outputRow, "G") = wsSource.Cells(1, cc)
                ' 输出行号下移
                outputRow = outputRow + 1
            End If
        Next
    Next
    
    ' 自动调整结果表列宽
    wsTarget.UsedRange.EntireColumn.AutoFit
End Sub

若实际表格列位置和示例有差异，直接修改代码中对应的列号、列标即可，核心遍历逻辑无需调整。

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