代码错误，麻烦修改一下错误位置headerText = headerCell.Value

飞云流水

Sub CopyDataByHeaders()
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim headerRangeSource As Range, headerRangeTarget As Range
    Dim headerCell As Range
    Dim colIndexSource As Long, colIndexTarget As Long
    Dim lastRowSource As Long, lastRowTarget As Long

    ' 设置源表和目标表
    Set wsSource = ThisWorkbook.Sheets("Sheet1") ' 修改为源数据表名称
    Set wsTarget = ThisWorkbook.Sheets("Sheet2") ' 修改为目标表名称

    ' 设置源表和目标表的表头范围（假设表头在第一行）
    Set headerRangeSource = wsSource.Rows(1)
    Set headerRangeTarget = wsTarget.Rows(1)

    ' 遍历目标表的表头
    For Each headerCell In headerRangeTarget
        ' 获取目标表表头名称
        Dim headerText As String
        headerText = headerCell.Value

        ' 在源表中查找对应的列索引
        colIndexSource = 0
        On Error Resume Next
        colIndexSource = Application.WorksheetFunction.Match(headerText, headerRangeSource, 0)
        On Error GoTo 0

        If colIndexSource = 0 Then
            MsgBox "表头名称 '" & headerText & "' 在源表中未找到！"
        Else
            ' 获取源表的列数据（假设数据从第二行开始）
            lastRowSource = wsSource.Cells(wsSource.Rows.Count, colIndexSource).End(xlUp).Row
            wsSource.Columns(colIndexSource).Offset(1, 0).Resize(lastRowSource - 1, 1).Copy

            ' 获取目标表的列索引
            colIndexTarget = headerCell.Column

            ' 清除目标列的旧数据（可选）
            wsTarget.Columns(colIndexTarget).ClearContents

            ' 粘贴到目标表的对应列
            wsTarget.Cells(2, colIndexTarget).PasteSpecial xlPasteValues
        End If
    Next headerCell

    MsgBox "数据复制完成！"
End Sub

飞云流水

shiruiqiang

附件不传传图片，有这功夫

ykcbf1100

AI写的代码大部分不太靠谱，还不如上传附件说明需求新写一个。

gwjkkkkk

上传附件，应该比较简单！

lss001

飞云流水 发表于 2025-1-31 19:30

请参考一下附件代码

复制列数据1.zip (23.3 KB, 下载次数: 5)

2025-2-1 13:24 上传

点击文件名下载附件

gwjkkkkk

Option Explicit
Sub test1()
    Dim ar, j&, c&, cnn As Object, rst As Object, strSQL$, strFileName$, strJoin$
   
    Application.ScreenUpdating = False
    Set cnn = CreateObject("ADODB.Connection")
   
    With Worksheets(2)
        c = .Cells(1, .Columns.Count).End(xlToLeft).Column
        ar = Range(.Cells(1, "X"), .Cells(1, c)).Value
        For j = 1 To UBound(ar, 2)
            strJoin = strJoin & "," & ar(1, j)
        Next j
        
        strFileName = ThisWorkbook.FullName
        Select Case Application.Version * 1
            Case Is <= 11
                cnn.Open "Provider=Microsoft.JET.OLEDB.4.0;Data Source=" & strFileName & ";Extended Properties='Excel 8.0;HDR=YES;IMEX=0'"
            Case Is >= 12
                cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFileName & ";Extended Properties='Excel 12.0;HDR=YES;IMEX=0'"
        End Select
        
        strSQL = "SELECT " & Mid(strJoin, 2) & " FROM [" & Worksheets(1).Name & "$A1:C]"
        Set rst = cnn.Execute(strSQL)
   
        With .Range("X1")
            .CurrentRegion.Offset(1).Clear
            .Offset(1).CopyFromRecordset rst
        End With
        .Activate
    End With
   
    rst.Close: cnn.Close
    Set rst = Nothing: Set cnn = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

飞云流水

lss001 发表于 2025-2-1 13:25
请参考一下附件代码

多谢，这个也可以