如何为4个独立数据元素复制索引范围？VBA批量复制行添加公司列

看起来你已经搞定了基础的遍历提取逻辑，现在只需要在拿到每行数据后，循环4次分别绑定不同公司名称写入就行。我帮你修改并补全了代码，确保实现每行源数据对应4条带不同公司的记录：

Sub Address_Raw()
    Dim dataBook As Workbook
    Dim Address_Raw As Worksheet, Del_Tax As Worksheet
    Dim lastRow As Long, i As Long, targetRow As Long
    Dim extractedVal1 As Variant, extractedVal2 As Variant
    Dim companies As Variant ' 存储4个公司名称的数组
    
    ' 初始化公司数组，方便统一管理
    companies = Array("Company1", "Company2", "Company3", "Company4")
    
    ' 设置工作簿和工作表对象，记得替换成你实际的表名
    Set dataBook = ThisWorkbook
    Set Address_Raw = dataBook.Worksheets("源工作表名称")
    Set Del_Tax = dataBook.Worksheets("目标工作表名称")
    
    ' 获取源表最后一行（假设数据在A列，可根据实际调整列）
    lastRow = Address_Raw.Cells(Address_Raw.Rows.Count, "A").End(xlUp).Row
    
    ' 初始化目标表起始行（假设第1行是表头，从第2行开始写数据）
    targetRow = 2
    
    ' 遍历源表非空行（假设源表第1行是表头，从第2行开始遍历）
    For i = 2 To lastRow
        ' 提取你需要的两个值，这里假设是A、B列，根据你的实际需求调整列
        extractedVal1 = Address_Raw.Cells(i, "A").Value
        extractedVal2 = Address_Raw.Cells(i, "B").Value
        
        ' 循环写入4个公司对应的记录
        For Each comp In companies
            ' 写入提取的两个值+对应公司名称
            Del_Tax.Cells(targetRow, "A").Value = extractedVal1
            Del_Tax.Cells(targetRow, "B").Value = extractedVal2
            Del_Tax.Cells(targetRow, "C").Value = comp
            
            ' 目标行号递增，避免覆盖已有数据
            targetRow = targetRow + 1
        Next comp
    Next i
    
    ' 可选：自动调整目标表列宽，让内容显示更美观
    Del_Tax.Columns.AutoFit
    
    MsgBox "数据处理完成！共生成 " & (lastRow - 1) * 4 & " 条记录。", vbInformation
End Sub

关键修改说明： #

• 新增companies数组存储4个公司名称，后续要修改公司名直接改数组就行，不用改循环逻辑
• 在源表行遍历的内部，加了一层For Each循环，把每行提取的两个值分别和4个公司组合，写入目标表
• 用targetRow变量跟踪目标表的写入位置，确保每条记录依次往下排，不会出现覆盖问题
• 保留了你原有的工作表对象逻辑，只需要替换成你实际的工作表名称即可

注意事项： #

1. 请根据你的实际数据位置，调整提取值的列（比如把"A"、"B"改成你实际用的列号或列名）
2. 如果源表的表头行不是第1行，或者目标表的起始行不是第2行，记得修改对应的循环起始值和targetRow初始值
3. 运行前建议备份数据，避免意外覆盖已有内容

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