Question

我已经在这个工作了几个星期了，我似乎无法做对。这个概念看起来很简单，这就是为什么我对此感到非常沮丧。我最后在这里张贴了一些输入。

这背后的想法类似于vlookup（我尝试了vlookup并获得了我不想要的结果）。在ThisWorkbook上，我将“Desc”设置为等于单元格B7。然后我想在一个单独的工作簿中查找这个数据库。一旦在数据库中找到“Desc”，我想复制D列中的数据并将其粘贴到原始工作簿中“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

Answer 1

未测试：

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

Answer 2

试试这个：

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

Answer 3

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

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

3 个答案: