复制粘贴

尔奈

表A是源数据，首先确保表A是一个矩形数据，表B的A列的数据可以在表A的列标题中找到，表C是要粘贴的位置。依次将表B A1的值查询在表A的哪一列，并将该列的数据复制值粘贴到表C的第一列，但不覆盖掉表C之前的数据，将表B A2的值查询在表A的哪一列，并将该列的数据复制值粘贴到表C的第2列，但不覆盖掉表C之前的数据，以此类推，直到将表b  A列的值为空时停止，请写一段EXCEL代码

ynzsvt

看着有点像高级筛选，建议提供文件并叙述清楚。

尔奈

图片 ，如图所示

sdytsxd991122

尔奈 发表于 2024-8-4 11:55
图片 ，如图所示

贴图不如贴附件

尔奈

sdytsxd991122 发表于 2024-8-4 11:58
贴图不如贴附件

附件已上传

sdytsxd991122

蜗牛等我

这个不错，很好，学习

尔奈

Sub FUZHI()
    Dim sourceSheet As Worksheet, ruleSheet As Worksheet, destSheet As Worksheet
    Dim sourceLastRow As Long, destLastRow As Long, rulelastrow As Long, i As Long, j As Long
    Dim sourceColIdx As Long, destColIdx As Long
   
    ' 设置工作表对象
    Set sourceSheet = ThisWorkbook.Sheets("源数据")
    Set ruleSheet = ThisWorkbook.Sheets("规则")
    Set destSheet = ThisWorkbook.Sheets("销售")
   
    ' 获取源数据表的最后一个数据行
    sourceLastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
   
    ' 获取目标数据表的最后一行有数据的单元格
    destLastRow = destSheet.Cells(destSheet.Rows.Count, "A").End(xlUp).Row + 1
    rulelastrow = ruleSheet.Cells(ruleSheet.Rows.Count, "A").End(xlUp).Row
   
    ' 遍历规则表的A列
    For i = 1 To rulelastrow
        ' 查找列标题在源数据表中的位置
        sourceColIdx = Application.Match(ruleSheet.Cells(i, 1).Value, sourceSheet.Rows(1), 0)
        
        If IsNumeric(sourceColIdx) Then
            ' 确定目标列的列号
            destColIdx = i
            
            ' 确保目标列的起始单元格是空的，避免覆盖数据
            While destSheet.Cells(destLastRow, destColIdx).Value <> ""
                destLastRow = destLastRow + 1
            Wend
            
            ' 复制数据并粘贴到目标数据表
            sourceSheet.Range("A2:A" & sourceLastRow).Columns(sourceColIdx).Copy
            destSheet.Cells(destLastRow, destColIdx).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Else
            ' 如果没有找到列标题，则输出错误信息
            Debug.Print "未找到列标题: " & ruleSheet.Cells(i, 1).Value
        End If
    Next i
   
    MsgBox "数据复制完成。"
End Sub