查找并将单个列从一个excel复制到另一个excel

Question

我有一个脚本，它将A列和B列的值复制到另一个Excel的A列和B列。列标题相同。 我想要的是从第二个Excel中的第一列Excel值查找，如果有匹配，则获取相应的值 列B在同一行中的值，并将其粘贴到第一个Excel中。如果没有匹配项，则在第一个Excel的B列中插入#N / A. 第二个Excel应该没有变化（我们查找值）。第一个Excel中的Colummn B为空。

Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWorkbook = objExcel.Workbooks.Open("C:\TEST.xlsx")
Set objWorkbook2 = objExcel.Workbooks.Open("C:\Desktop\IPT\Test.xlsx")
'objExcel.DisplayAlerts = False
Set objWorksheet = objWorkbook.Worksheets(1)
objWorksheet.Activate

Set objRange = objWorkSheet.Range("A:B").EntireColumn
objWorkSheet.Range("A:B").EntireColumn.Copy

Set objWorksheet2 = objWorkbook2.Worksheets(1)
objWorksheet.Activate

Set objRange = objWorkSheet2.Range("A:B")
objWorkSheet2.Paste objWorkSheet2.Range("A:B")
objWorksheet2.Paste(objRange)

objworkbook2.Save

objWorkbook.close("C:\TEST.xlsx")
objWorkbook2.close("C:\Desktop\IPT\Test.xlsx")

objExcel.Quit 
objExcel.DisplayAlerts = True

这是第一个Excel

A   B   C
101     12
102     13
103     15

第二个Excel文件

A   B   C
101 Toy1    small
102 Toy2    medium
103 Toy3    high

更新的代码：

ProcessFiles()
Sub ProcessFiles()

    Const xlUp = -4162
    Const vbCritical = 16

    Const BOOK1 = "C:\TEST.xlsx.xls"
    Const BOOK2 = "C:\Desktop\IPT\Test.xlsx"

    Dim xlApp, xlWB, dict, r
    Set dict = CreateObject("Scripting.Dictionary")
    Set xlApp = CreateObject("Excel.Application")

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    If objFSO.FolderExists(BOOK1) Then
        MsgBox BOOK1 & " not found", vbCritical
        Exit Sub
    ElseIf objFSO.FolderExists(BOOK2) Then
        MsgBox BOOK2 & " not found", vbCritical
        Exit Sub
    End If
    Set objFSO = Nothing

    Set xlWB = xlApp.Workbooks.Open(BOOK2)
    With xlWB.Worksheets(1)

        For Each r In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))

            If Not dict.Exists(r.Text) Then dict.Add r.Text, r.Offset(0, 1).Value

        Next

    End With
    xlWB.Close False

    Set xlWB = xlApp.Workbooks.Open(BOOK1)
    With xlWB.Worksheets(1)

        For Each r In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))

            'r.Offset(0, 4) = IIf(dict.Exists(r.Text), dict(r.Text), "#N/A")
            If dict.Exists(r.Text) Then
                r.Offset(0, 4) = dict(r.Text)
             Else
                r.Offset(0, 4) = "#N/A"
      End If

        Next

    End With
    xlWB.Close True

End Sub

Answer 1

脚本字典可以轻松比较列表。

Sub ProcessFiles()

    Const xlUp = -4162
    Const vbCritical = 16

    Const BOOK1 = "\\norfile5\Public\Table Games\Spotlights\Back Up\SO\Book1.xlsx"
    Const BOOK2 = "\\norfile5\Public\Table Games\Spotlights\Back Up\SO\Book2.xlsx"

    Dim xlApp, xlWB, dict, r
    Set dict = CreateObject("Scripting.Dictionary")
    Set xlApp = CreateObject("Excel.Application")

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    If objFSO.FolderExists(BOOK1) Then
        MsgBox BOOK1 & " not found", vbCritical
        Exit Sub
    ElseIf objFSO.FolderExists(BOOK2) Then
        MsgBox BOOK2 & " not found", vbCritical
        Exit Sub
    End If
    Set objFSO = Nothing

    Set xlWB = xlApp.Workbooks.Open(BOOK2)
    With xlWB.Worksheets(1)

        For Each r In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))

            If Not dict.Exists(r.Text) Then dict.Add r.Text, r.Offset(0, 1).Value

        Next

    End With

    xlWB.Close False

    Set xlWB = xlApp.Workbooks.Open(BOOK1)
    With xlWB.Worksheets(1)

        For Each r In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))

        If dict.Exists(r.Text) then 
            r.Offset(0, 1) =  dict(r.Text)
        Else
            r.Offset(0, 1) =  "#N/A"
        End If

        Next

    End With

    xlWB.Save 

    xlWB.Close False

    xlApp.Quit

    Msgbox BOOK1 & " has been updated"
End Sub

Answer 2

我可以想到两种方法来做到这一点。

1. 创建一个系统将数据组织到数组中，然后使用几个简单的算法将事物滑动到位。这将需要逐个单元地解析以检索数据。

我更喜欢这种方法，因为它本身可能是一个非常抽象的程序。如果你这样做，我强烈建议使用arraylists。

1. 将VLookup（）函数插入Book1：B列单元格

我相信这会更乏味......