vba 在单独的工作簿中查找值并将数据复制到此工作簿

Looking Up Values in Separate Workbook and Copying Data to This Workbook

提问by GarretB

I've been working on this one for a couple weeks now and I can't seem to get it right. The concept seems easy which is why I'm so frustrated with it. I finally resorted to posting here for some input.

我已经在这个问题上工作了几个星期，但我似乎无法把它做好。这个概念看起来很简单，这就是为什么我对它如此沮丧。我终于求助于在这里发布一些意见。

The idea behind this is similar to a vlookup (I tried vlookup and got a result I wasn't looking for). On ThisWorkbook, I set "Desc" equal to cell B7. I then want to look this up in a separate workbook which is the database. Once "Desc" is found in the database, I want to copy the data in column D and paste it to the cell to the right of "Desc" in the original workbook. I need to repeat the Copy-Paste process for the rest of the cells in column B under "Desc". Thanks in advance. Cheers.

这背后的想法类似于 vlookup（我尝试了 vlookup 并得到了我不想要的结果）。在 ThisWorkbook 上，我将“Desc”设置为等于单元格 B7。然后我想在一个单独的工作簿中查找它，该工作簿是数据库。在数据库中找到“Desc”后，我想复制 D 列中的数据并将其粘贴到原始工作簿中“Desc”右侧的单元格中。我需要对“Desc”下 B 列中的其余单元格重复复制粘贴过程。提前致谢。干杯。

Option Explicit

Dim i As Integer, n As Integer
Dim Desc As Range, ExDesc As Range
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet

Sub Retrieve()
Application.ScreenUpdating = False

Set wb1 = ThisWorkbook
Set ws1 = wb1.Sheets("Import")
ws1.Range("C7:C100000").ClearContents

With ws1
    i = 7
    Do Until .Cells(i, 2) = ""
        Set Desc = ws1.Cells(i, 2)
        With Workbooks.Open("C:\Users\Username\Desktop\Database.xlsm")
            Set wb2 = ActiveWorkbook
            Set ws2 = wb2.Sheets("Data")
            n = 2
            Do Until ws2.Cells(n, 2) = ""
                Set ExDesc = Cells(n, 2)
                If ExDesc = Desc Then
                    ExDesc.Offset(0,2).Copy
                End If
                n = n + 1
            Loop
        End With
        i = i + 1
    Loop
End With
End Sub

Public Sub Paste()
wb1.Activate
ws1.Cells(i, 3).Paste
End Sub 

回答by Tim Williams

Untested:

未经测试：

Sub Retrieve()

Dim i As Integer, n As Integer
Dim Desc As Range, ExDesc As Range
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rngLookup As Range
Dim v

Application.ScreenUpdating = False

Set wb1 = ThisWorkbook
Set ws1 = wb1.Sheets("Import")
ws1.Range("C7:C100000").ClearContents

Set wb2 = Workbooks.Open("C:\Users\Username\Desktop\Database.xlsm")
With wb2.Sheets("Data")
    Set rngLookup = .Range(.Cells(7, 2), _
                    .Cells(7, 2).End(xlDown)).Resize(, 3)
End With

With ws1
    i = 7
    Do Until .Cells(i, 2) = ""
        v = Application.VLookup(.Cells(i, 2).Value, rngLookup, 3, False)
        If Not IsError(v) Then .Cells(i, 4).Value = v
        i = i + 1
    Loop
End With

wb2.Close False


End Sub

回答by Alex

Try this:

尝试这个：

Sub Retrieve()
Application.ScreenUpdating = False
Dim lookuprng As Range

Set wb1 = ThisWorkbook
Set wb2 = Workbooks.Open("C:\Users\username\Desktop\Database.xlsm")
Set lookuprng = wb2.Sheets("Data").Range("look up range in Database")
Set ws1 = wb1.Sheets("Import")
ws1.Range("C7:C100000").ClearContents
wb1.Activate
With ws1
i = 7
Do Until .Cells(i, 2) = ""
    Cells(i, 5).Value = Application.VLookup(Cells(i, 2).Value, lookuprng, 2, 0)
    i = i + 1
Loop
End With
End Sub

回答by pnuts

You mentioned I tried vlookup and got a result I wasn't looking forbut this should work, though you would have to update links if the sheet with the lookup table is not open in the same session.

您提到过，I tried vlookup and got a result I wasn't looking for但这应该可行，但如果具有查找表的工作表未在同一会话中打开，则您必须更新链接。