VBA，使用标题名称将值从一张图纸复制到另一张图纸

我想将值从工作表A复制到工作表B，但让它在两个工作表中的标题之间循环，在工作表B中查找标题，并根据标题将值从工作表A粘贴到B中。这背后的原因是，标题不在相同的列名中，因此直接复制和粘贴将不起作用

我有一张可以正常复制粘贴的照片。但是我如何才能让它在工作表B中的现有标题中循环，标题将在第1行中预定义。粘贴在复制粘贴部分

    Sub stack()

Dim i As Integer
Dim y As Integer
Dim src As Range
Dim tgt As Range
Dim Headloop As String
Dim Headloop2 As String

Set src = Sheets("sheet1")  'source sheet
Set tgt = Sheets("sheet2")   'destination sheet

With tgt
For i = 1 To max_col
    Headloop = Range(i & "1").value 'i is column Number, "1" is row 1
Next i
End With

With src
For y = 1 To max_col
    Headloop2 = Range(y & "1").value 'y is column Number, "1" is row 1
Next y
End With

 For Each i In tgt
    If Headloop > 0 Then
    Range(y&"2"),src.Copy Destination: = tgt.range(i&"2").value
    End If
Next i


End Sub

---

谢谢。

这里是一个基本原理示例

我假设源标题位于工作表1的第1行，因此请使用：

Intersect(.Rows(1), .UsedRange).SpecialCells(xlCellTypeConstants)

查找该行中的所有标题并在其上循环

每个源标题都是当前的

rng.Value

我使用

Find

将其与表2的第1行匹配

trgt.Rows(1).Find(rng.Value, LookIn:=xlValues, lookat:=xlWhole)

如果找到，则复制标题下的数据：

If Not trgtCell Is Nothing Then
                .Range(rng.Offset(1), .Cells(.Rows.Count, rng.Column).End(xlUp)).Copy

我使用匹配的单元格

trgtCell

，来确定要粘贴到的列

我使用粘贴到该列中的下一个可用行

 .Cells(.Rows.Count, trgtCell.Column).End(xlUp).Row + 1

---

代码：

Option Explicit
Sub CopyByHeaders()
    Dim rng As Range, trgtCell As Range, src As Worksheet, trgt As Worksheet
    Set src = Worksheets("Sheet1")
    Set trgt = Worksheets("Sheet2")
    Application.ScreenUpdating = False
    With src
        For Each rng In Intersect(.Rows(1), .UsedRange).SpecialCells(xlCellTypeConstants)       
            Set trgtCell = trgt.Rows(1).Find(rng.Value, LookIn:=xlValues, lookat:=xlWhole)
            If Not trgtCell Is Nothing Then
                .Range(rng.Offset(1), .Cells(.Rows.Count, rng.Column).End(xlUp)).Copy
                With trgt
                    .Range(Split(trgtCell.Address, "$")(1) & .Cells(.Rows.Count, trgtCell.Column).End(xlUp).Row + 1).PasteSpecial
                End With
            End If
        Next rng
    End With
    Application.ScreenUpdating = True
End Sub

要仅粘贴到目标的第2行，请使用：

 .Range(Split(trgtCell.Address, "$")(1) & 2).PasteSpecial

---

下面是一个基本原理示例

我假设源标题位于工作表1的第1行，因此请使用：

Intersect(.Rows(1), .UsedRange).SpecialCells(xlCellTypeConstants)

查找该行中的所有标题并在其上循环

每个源标题都是当前的

rng.Value

我使用

Find

将其与表2的第1行匹配

trgt.Rows(1).Find(rng.Value, LookIn:=xlValues, lookat:=xlWhole)

如果找到，则复制标题下的数据：

If Not trgtCell Is Nothing Then
                .Range(rng.Offset(1), .Cells(.Rows.Count, rng.Column).End(xlUp)).Copy

我使用匹配的单元格

trgtCell

，来确定要粘贴到的列

我使用粘贴到该列中的下一个可用行

 .Cells(.Rows.Count, trgtCell.Column).End(xlUp).Row + 1

---

代码：

Option Explicit
Sub CopyByHeaders()
    Dim rng As Range, trgtCell As Range, src As Worksheet, trgt As Worksheet
    Set src = Worksheets("Sheet1")
    Set trgt = Worksheets("Sheet2")
    Application.ScreenUpdating = False
    With src
        For Each rng In Intersect(.Rows(1), .UsedRange).SpecialCells(xlCellTypeConstants)       
            Set trgtCell = trgt.Rows(1).Find(rng.Value, LookIn:=xlValues, lookat:=xlWhole)
            If Not trgtCell Is Nothing Then
                .Range(rng.Offset(1), .Cells(.Rows.Count, rng.Column).End(xlUp)).Copy
                With trgt
                    .Range(Split(trgtCell.Address, "$")(1) & .Cells(.Rows.Count, trgtCell.Column).End(xlUp).Row + 1).PasteSpecial
                End With
            End If
        Next rng
    End With
    Application.ScreenUpdating = True
End Sub

要仅粘贴到目标的第2行，请使用：

 .Range(Split(trgtCell.Address, "$")(1) & 2).PasteSpecial

---

未经测试，但这里的想法是迭代目标数据表标题行中的单元格（

h=1到destination.cells.Count

），然后使用

Index

函数获取源数据表上相应的列号（如果该列不存在，则返回错误）。然后就是简单的复制/粘贴

Dim s1 as Worksheet, s2 as Worksheet
Dim dataToCopy as Range, sourceData as Range, destination as Range
Dim h as Long, headerName as String
Dim columnNumber as Variant

Set s1 = Worksheets("Sheet1")           'modify as needed
Set s2 = Worksheets("Sheet2")           'modify as needed
Set destination = s2.Range("A1:A" & max_col) 
Set sourceData = s2.Range("A1:Z100")    'modify as needed

For h = 1 to destination.Cells.Count
    headerName = destination.Cells(1,h).Value
    columnNumber = Application.Index(headerName, sourceData.Rows(1), False)
    If IsError(columnNumber) Then
        ' this header wasn't found
        MsgBox headerName & " is not found on the source sheet!", vbCritical
    Else
        Set dataToCopy = sourceData.Columns(columnNumber)
        ' skip the header row
        Set dataToCopy = dataToCopy.Resize(sourceData.Rows.Count - 1).Offset(1)
        dataToCopy.Copy destination.Cells(1,h).Offset(1)
    End If
Next

---

未经测试，但这里的想法是迭代目标数据表标题行中的单元格（

h=1到destination.cells.Count

），然后使用

Index

函数获取源数据表上相应的列号（如果该列不存在，则返回错误）。然后就是简单的复制/粘贴

Dim s1 as Worksheet, s2 as Worksheet
Dim dataToCopy as Range, sourceData as Range, destination as Range
Dim h as Long, headerName as String
Dim columnNumber as Variant

Set s1 = Worksheets("Sheet1")           'modify as needed
Set s2 = Worksheets("Sheet2")           'modify as needed
Set destination = s2.Range("A1:A" & max_col) 
Set sourceData = s2.Range("A1:Z100")    'modify as needed

For h = 1 to destination.Cells.Count
    headerName = destination.Cells(1,h).Value
    columnNumber = Application.Index(headerName, sourceData.Rows(1), False)
    If IsError(columnNumber) Then
        ' this header wasn't found
        MsgBox headerName & " is not found on the source sheet!", vbCritical
    Else
        Set dataToCopy = sourceData.Columns(columnNumber)
        ' skip the header row
        Set dataToCopy = dataToCopy.Resize(sourceData.Rows.Count - 1).Offset(1)
        dataToCopy.Copy destination.Cells(1,h).Offset(1)
    End If
Next

---

您可以使用

Index

函数查找标题的列号。这段代码无法编译。您已经为循环和未声明/未分配的对象变量打开了

。请修改。这个代码是做什么的？它实际上似乎什么都不做，只是在循环中为字符串变量赋值，然后立即处理这些变量，而不使用它们
max_col
仍然未定义和分配。很抱歉，max col是我模块中的一个函数，它获取工作表中的max列。代码没有完全正常工作，因为它是一个WIPOK，所以您发布的代码仍然毫无用处。所以，如果你认为这是一个“能够正常复制和粘贴的部分”，那你就大错特错了。对不起，我同意它除了循环遍历列并给列分配编号之外什么都不做，我想我会给它一个机会，需要做复制和粘贴部分。你可以使用
Index
函数来查找标题的列编号。这段代码无法编译。您已经为

循环和未声明/未分配的对象变量打开了

。请修改。这个代码是做什么的？它实际上似乎什么都不做，只是在循环中为字符串变量赋值，然后立即处理这些变量，而不使用它们
max_col
仍然未定义和分配。很抱歉，max col是我模块中的一个函数，它获取工作表中的max列。代码没有完全正常工作，因为它是一个WIPOK，所以您发布的代码仍然毫无用处。所以，如果你认为这是一个“正常复制和粘贴的作品”，你就大错特错了。对不起，我同意它除了循环列并给列分配编号之外什么都不做，我想我会给它一个机会，需要做复制和粘贴部分。