Excel VBA代码仅匹配首个Item及i值问题求助

我帮你梳理下问题根源，然后给出修复后的代码和关键说明，保证能覆盖所有匹配的Item-i组合：

问题根源 #

你的代码大概率只完成了单次匹配和复制：要么只找到了第一个包含ParName的表头列就停止遍历，要么行的处理逻辑没有覆盖所有数据行，导致只有首个Item和i值生效。

修复后的完整代码 #

Sub CopyColumnsCorrectly()
    Dim wsb As Worksheet, wso As Worksheet
    Dim lastRowWsb As Long, lastRowWso As Long
    Dim headerCell As Range
    Dim targetRow As Long
    
    ' 替换成你的实际工作簿和工作表引用
    Set wsb = Workbooks(Y).Sheets("REF") ' 确保Y是已定义的合法工作簿变量/名称
    Set wso = ThisWorkbook.Sheets("你的目标工作表名称") ' 替换为wso的实际名称
    
    ' 获取wsb中B列的最后数据行
    lastRowWsb = wsb.Cells(wsb.Rows.Count, "B").End(xlUp).Row
    
    ' 复制B列所有数据到wso的B列（包含表头）
    wsb.Range("B1:B" & lastRowWsb).Copy Destination:=wso.Range("B1")
    
    ' 遍历wsb的表头行（假设表头在第1行，按需调整）
    For Each headerCell In wsb.Range("1:1")
        ' 判断表头是否包含"ParName"（不区分大小写）
        If InStr(1, headerCell.Value, "ParName", vbTextCompare) > 0 Then
            ' 获取当前ParName列的所有数据（从表头到最后行）
            Dim parNameData As Range
            Set parNameData = wsb.Range(headerCell, wsb.Cells(lastRowWsb, headerCell.Column))
            
            ' 计算wso中H列的目标粘贴行（追加模式，避免覆盖）
            lastRowWso = wso.Cells(wso.Rows.Count, "H").End(xlUp).Row
            targetRow = IIf(lastRowWso = 1 And wso.Range("H1").Value = "", 1, lastRowWso + 1)
            
            ' 复制当前ParName列数据到wso的H列
            parNameData.Copy Destination:=wso.Range("H" & targetRow)
        End If
    Next headerCell
    
    ' 清除剪贴板，避免弹窗提示
    Application.CutCopyMode = False
End Sub

关键修复点说明 #

• 遍历所有表头：用For Each headerCell In wsb.Range("1:1")循环检查每一个表头单元格，不会遗漏任何包含ParName的列
• 动态获取最后行：分别计算源表和目标表的最后数据行，确保复制全部数据且不覆盖已有内容
• 灵活匹配表头：vbTextCompare参数让匹配不区分大小写，不管表头是ParName、parname还是PARNAME都能识别
• 处理空目标列：用IIf判断目标列是否为空，避免出现从第二行开始粘贴的错误

额外注意事项 #

• 确保变量Y是合法的工作簿引用（比如是工作簿名称字符串，或者已提前定义的工作簿对象）
• 如果你的表头不在第1行，把wsb.Range("1:1")改成实际的表头行范围，比如wsb.Range("3:3")
• 如果需要覆盖目标表H列的原有数据，直接把targetRow设为1即可

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