Excel VBA实现跨工作表多列规则合并转单列复制

你原有代码的核心问题是只处理了Attribute单列表格的复制，没有覆盖三类规则列的行转列合并逻辑，同时存在一处笔误、硬编码遍历行数的问题，按以下逻辑调整即可：

• 复用你已写的columnLookup列查找函数，额外定位源表中completeness/accuracy/validity三个规则列的位置，同时定位目标表中规则类型、规则内容列的位置
• 先清空目标表原有残留数据，避免旧内容干扰
• 遍历源表每一行有效数据时，对三个规则列逐个判断：如果单元格非空，就向目标表写入对应属性名、规则类型、规则内容三条信息，每写入一条目标表行号自增1
• 修正原有代码中Work Worksheets的笔误，去掉不必要的工作表Activate激活操作，避免运行时屏幕跳闪

完整修改后的代码如下：

Function columnLookup(Name As String, Line As Range) As Integer
    Dim i As Integer
    Dim Cell As Range
    i = 0
    For Each Cell In Line
        If Cell.Value = Name Then
           i = Cell.Column
           Exit For '找到匹配列后直接退出循环，提升效率
        End If
    Next Cell
    columnLookup = i
End Function

Sub CopyfromSource()
    Dim sourceWs As Worksheet, targetWs As Worksheet
    Dim lastSourceRow As Long, currentTargetRow As Long
    Dim headerSource As Range, headerCopy As Range
    Dim colAttriSource As Integer, colAttriTarget As Integer
    Dim colComp As Integer, colAcc As Integer, colVal As Integer
    Dim colRuleType As Integer, colRuleContent As Integer
    Dim rowIdx As Long, ruleCols As Variant, ruleType As Variant
    
    '绑定工作表，无需激活切换
    Set sourceWs = ThisWorkbook.Worksheets("Source")
    Set targetWs = ThisWorkbook.Worksheets("Copy")
    
    '定位表头范围
    Set headerSource = sourceWs.Range("A1", sourceWs.Range("A1").End(xlToRight))
    Set headerCopy = targetWs.Range("A1", targetWs.Range("A1").End(xlToRight))
    
    '查找所有需要的列号
    colAttriSource = columnLookup("Attribute", headerSource)
    colComp = columnLookup("completeness", headerSource)
    colAcc = columnLookup("accuracy", headerSource)
    colVal = columnLookup("validity", headerSource)
    
    colAttriTarget = columnLookup("Attribute", headerCopy)
    colRuleType = columnLookup("RuleType", headerCopy) '替换为你目标表实际的规则类型列表头
    colRuleContent = columnLookup("RuleContent", headerCopy) '替换为你目标表实际的规则内容列表头
    
    '清空目标表原有数据（保留表头）
    If targetWs.Range("A2") <> "" Then
        targetWs.Range("A2", targetWs.Cells(targetWs.Rows.Count, colRuleContent).End(xlUp)).ClearContents
    End If
    
    '获取源表最后一行有效数据行号，避免硬编码
    lastSourceRow = sourceWs.Cells(sourceWs.Rows.Count, colAttriSource).End(xlUp).Row
    currentTargetRow = 2
    
    '定义要遍历的规则列和对应类型名的映射
    ruleCols = Array(Array(colComp, "completeness"), Array(colAcc, "accuracy"), Array(colVal, "validity"))
    
    '逐行遍历源表数据
    For rowIdx = 2 To lastSourceRow
        Dim attriVal As String
        attriVal = sourceWs.Cells(rowIdx, colAttriSource).Value
        '逐类判断规则列是否有内容，有内容就写入目标表
        For Each ruleType In ruleCols
            Dim ruleVal As String
            ruleVal = sourceWs.Cells(rowIdx, ruleType(0)).Value
            If Trim(ruleVal) <> "" Then
                targetWs.Cells(currentTargetRow, colAttriTarget).Value = attriVal
                targetWs.Cells(currentTargetRow, colRuleType).Value = ruleType(1)
                targetWs.Cells(currentTargetRow, colRuleContent).Value = ruleVal
                currentTargetRow = currentTargetRow + 1
            End If
        Next
    Next rowIdx
    
    '如果需要复制最终生成的目标表为新文件，保留以下代码，不需要可注释掉
    targetWs.Copy
End Sub

注意：代码中RuleType和RuleContent是目标Copy表的默认表头名，如果你实际表格里的表头命名不同，直接替换columnLookup里对应的字符串即可；代码会自动跳过空的规则单元格，不会生成无内容的空行。

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