粘贴时 Excel VBA 匹配列

Question

我在 excel 中有一小部分数据，有 4 列

File A: 

  SNO   TYPE  CountryA   CountryB   CountryD
    1    T1    A1          B2         D1          
    2    T2    A2          B2         D2

我在另一个 excel 文件中有这些数据

File B:

   SNO   TYPE  CountryB  CountryA CountryC
    11    T10   B10         A10     C10
    22    T20   B20         A20     C20
    33    T30   B30         A30     C30

现在，如果我想将文件 B 中的数据粘贴到文件 A 中的数据上，我希望列名使用一些 vba 代码自动对齐。

所以最终结果应该是这样的，

       SNO  TYPE CountryA    CountryB  CountryC  CountryD           
        1    T1   A1           B1         --         D1
        2    T2   A2           B2         --         D2 
        11   T10  A10          B10        C10        --
        22   T20  A20          B20        C20        --
        33   T30  A30          B30        C30        -- 

Answer 1

这应该适合你：

Sub MatchUpColumnDataBasedOnHeaders()

Dim wbk As Workbook
Set wbk = ThisWorkbook
Set ws = wbk.Sheets(1)
Set ws2 = wbk.Sheets(2)
Dim cell As Range
Dim refcell As Range

Application.ScreenUpdating = False
ws.Select

    For Each cell In ws.Range("A1:Z1")

        cell.Activate
        ActiveCell.EntireColumn.Copy

        For Each refcell In ws2.Range("A1:Z1")
            If refcell.Value = cell.Value Then refcell.PasteSpecial (xlPasteValues)
        Next refcell

    Next cell
Application.ScreenUpdating = True

End Sub

这很有趣，我觉得有一种非常简单的非 VBA 方法可以做到这一点 - 但我在谷歌上找不到它的按钮。这适用于表格 1 和 2 上的 A 到 Z 列。假设您的标题位于第 1 行。

编辑 - 补充：

我注意到您想对文件执行此操作，但您没有提及有关工作表的任何内容。这就是您对不同工作簿的处理方式：

Sub MatchUpColumnDataBasedOnHeadersInFiles()

Dim wbk As Workbook

Set wbk = ThisWorkbook

Workbooks.Open Filename:="C:\PasteIntoWorkbook.xlsx"
Set wbk2 = Workbooks("PasteIntoWorkbook.xlsx")

Set ws = wbk.Sheets(1)
Set ws2 = wbk2.Sheets(1)

Dim cell As Range
Dim refcell As Range

wbk.Activate

Application.ScreenUpdating = False

ws.Select

    For Each cell In ws.Range("A1:N1")

        wbk.Activate
        ws.Select

        cell.Activate
        ActiveCell.EntireColumn.Copy

        wbk2.Activate
        ws2.Select

        For Each refcell In ws2.Range("A1:N1")
            If refcell.Value = cell.Value Then refcell.PasteSpecial (xlPasteValues)
        Next refcell

    Next cell

ws2.Select
Range("A1").Select
wbk.Activate
ws.Select
Range("A1").Select

Application.ScreenUpdating = True

End Sub

因此，如果您下定决心使用不同的 .xls 文件，那么您就是这样做的。您显然只需要将文件路径调整为粘贴到文件中的任何内容。

Answer 2

匹配列编码

Sheet2 = 您的原始标题（仅需要的标题 - 将它们放入第 1 行）

Sheet1 = 您的数据以及标题，但标题不同步，可能有更多或更少的标题，但您希望您的数据与 sheet2 中的标题一致

现在将您的数据放入 sheet2 中（第 2 行）中已经存在于 sheet2 中的标题下方，并运行以下编码，您的数据将按照所需的标题显示。

Sub Rahul()


Dim Orig_Range As Range
Dim New_Range As Range
Dim ToMove As Range
Dim RowOld, RowNew As Long
Dim ColOld, ColNew As Long
Dim WSD As Worksheet
Dim Cname As String

Set WSD = ActiveSheet

ColOld = WSD.Cells(1, Application.Columns.Count).End(xlToLeft).Column

ColNew = WSD.Cells(2, Application.Columns.Count).End(xlToLeft).Column

RowNew = WSD.Cells(Application.Rows.Count, 1).End(xlUp).Row

RowOld = 1


Set Orig_Range = Range(WSD.Cells(1, 1), WSD.Cells(1, ColOld))



For i = 1 To ColOld

Set New_Range = Range(WSD.Cells(2, 1), WSD.Cells(2, ColNew))


Cname = Orig_Range.Cells(RowOld, i).Value

Set ToMove = New_Range.Find(what:=Cname, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, MatchCase:=True)


If ToMove Is Nothing Then

New_Range.Cells(1, i).Resize(RowNew, 1).Select

Selection.Insert shift:=xlToRight




ElseIf Not ToMove.Column = i Then

ToMove.Resize(RowNew, 1).Select




Selection.Cut

New_Range.Cells(1, i).Select

Selection.Insert shift:=xlToRight

End If

Next i


End Sub