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 =您的原始HEADERS（仅限所需的标题 - 将它们放入第1行）

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

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

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

粘贴时Excel Excel VBA匹配列

2 个答案: