Question

我想将值从工作表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

谢谢。

Answer 1

这是一个基本的原理示例。

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

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

查找该行中的所有标题并将其循环。

每个源标头是当前的rng.Value。

我使用Find将它与sheet2的第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

Answer 2

未经测试，但是这里的想法是迭代目标表的标题行（For h = 1 to 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

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

2 个答案: