VBA - VLookup from Closed book (Fastest way ?)

[Ebraham]

Hi all,

I want to vlookup from an closed workbook. i have the below code which pulls up the particular column data from an closed book.
When i apply the formula(=VLOOKUP(B18,'C:\My Documents\Temp\[Demo.xls]Sheet1'!$A$1:$B$10,2,FALSE). the file size gets heavy. Is there an better way around please advise.

[TABLE="width: 64"]
 <colgroup><col width="64" style="width:48pt"> </colgroup><tbody>[TR]
  [TD="width: 64"]Sub copyColData()[/TD]
 [/TR]
 [TR]
  [TD][/TD]
 [/TR]
 [TR]
  [TD]Dim lastRow As Long[/TD]
 [/TR]
 [TR]
  [TD]Dim myApp As Excel.Application[/TD]
 [/TR]
 [TR]
  [TD]Dim wkBk As Workbook[/TD]
 [/TR]
 [TR]
  [TD]Dim wkSht As Object[/TD]
 [/TR]
 [TR]
  [TD][/TD]
 [/TR]
 [TR]
  [TD]Set myApp =  CreateObject("Excel.Application")[/TD]
 [/TR]
 [TR]
  [TD]Set wkBk = myApp.Workbooks.Open("C:\Users\Home\Downloads\Movies201(3).xlsm")[/TD]
 [/TR]
 [TR]
  [TD][/TD]
 [/TR]
 [TR]
  [TD]lastRow =  wkBk.Sheets(1).Range("D" & Rows.Count).End(xlUp).Row[/TD]
 [/TR]
 [TR]
  [TD]wkBk.Sheets(1).Range("D1:D"  & lastRow).Copy[/TD]
 [/TR]
 [TR]
  [TD]myApp.DisplayAlerts = False[/TD]
 [/TR]
 [TR]
  [TD]wkBk.Close[/TD]
 [/TR]
 [TR]
  [TD]myApp.Quit[/TD]
 [/TR]
 [TR]
  [TD][/TD]
 [/TR]
 [TR]
  [TD]Set wkBk = Nothing[/TD]
 [/TR]
 [TR]
  [TD]Set myApp = Nothing[/TD]
 [/TR]
 [TR]
  [TD]Set wkBk = ActiveWorkbook[/TD]
 [/TR]
 [TR]
  [TD]Set wkSht =  wkBk.Sheets("Sheet1")[/TD]
 [/TR]
 [TR]
  [TD][/TD]
 [/TR]
 [TR]
  [TD]wkSht.Activate[/TD]
 [/TR]
 [TR]
  [TD]Range("A1").Select[/TD]
 [/TR]
 [TR]
  [TD]wkSht.Paste[/TD]
 [/TR]
 [TR]
  [TD]Exit Sub[/TD]
 [/TR]
 [TR]
  [TD][/TD]
 [/TR]
 [TR]
  [TD]End Sub[/TD]
[/TR]
</tbody>[/TABLE]

 

[Worf]

Hi

Sub PopArray()                          'Uses ADO to populate an array
' add a reference to Microsoft ActiveX Data Objects 6.1 Library
Dim con As ADODB.Connection, rs As ADODB.Recordset, sr$, sf$, arr, sn$
sn = "execution"                        ' sheet name
sf = "c:\pub\3000_status.xlsm"          ' file path
sr = "a1:b10"                           ' desired range
Set con = New ADODB.Connection
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & sf & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=No"";"
Set rs = con.Execute("SELECT * FROM [" & sn & "$" & sr & "]")
arr = rs.GetRows
MsgBox WorksheetFunction.VLookup([b18], WorksheetFunction.Transpose(arr), 2, False)
rs.Close
Set con = Nothing
End Sub

 

[Ebraham]

Thanks for the reply. msgbox lines gives an type mismatch error.

Sub PopArray()                          'Uses ADO to populate an array
' add a reference to Microsoft ActiveX Data Objects 6.1 Library
Dim con As ADODB.Connection, rs As ADODB.Recordset, sr$, sf$, arr, sn$
sn = "Sheet1"                        ' sheet name
sf = "C:\Users\Home\Downloads\Movies2016.xlsm"          ' file path
sr = "a1:c10"                           ' desired range
Set con = New ADODB.Connection
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & sf & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=No"";"
Set rs = con.Execute("SELECT * FROM [" & sn & "$" & sr & "]")
arr = rs.GetRows
MsgBox WorksheetFunction.VLookup([a3], WorksheetFunction.Transpose(arr),3, False)
rs.Close
Set con = Nothing
End Sub

 

[Worf]

VLOOKUP is probably not finding a match. Try the version below, which also displays some information:

Sub PopArray()
' add a reference to Microsoft ActiveX Data Objects 6.1 Library
Dim con As ADODB.Connection, rs As ADODB.Recordset, sr$, sf$, arr, sn$, v
sn = "Sheet1"                        ' sheet name
sf = "c:\pub\3000_status.xlsm"       ' file path
sr = "a1:b10"                        ' desired range
Set con = New ADODB.Connection
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & sf & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=No"";"
Set rs = con.Execute("SELECT * FROM [" & sn & "$" & sr & "]")
arr = rs.GetRows
MsgBox "Cell A3 = " & [a3] & vbLf & "arr(0,5) = " & arr(0, 5) & vbLf & "arr(1,5) = " & _
arr(1, 5) & vbLf & "Upper bounds = " & UBound(arr, 1) & " and " & UBound(arr, 2)
On Error Resume Next
v = WorksheetFunction.VLookup([a3], WorksheetFunction.Transpose(arr), 2, False)
If Err.Number > 0 Then
    MsgBox "No match."
Else
    MsgBox v
End If
rs.Close
Set con = Nothing
On Error GoTo 0
End Sub

 

[Ebraham]

Thanks for the reply.

Below code is the easiest and works for me

[TABLE="width: 192"]
<colgroup><col span="3"></colgroup><tbody>[TR]
[TD="colspan: 3"]Sub nLookupFromClosedBook()[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="colspan: 3"]Dim myApp As Excel.Application[/TD]
[/TR]
[TR]
[TD="colspan: 3"]Dim wk As Workbook[/TD]
[/TR]
[TR]
[TD="colspan: 3"]Dim ws As Worksheet[/TD]
[/TR]
[TR]
[TD="colspan: 3"]Dim nArray() As Variant[/TD]
[/TR]
[TR]
[TD="colspan: 3"]Dim Question() As Variant[/TD]
[/TR]
[TR]
[TD="colspan: 3"]Dim Answer() As Variant[/TD]
[/TR]
[TR]
[TD="colspan: 3"]Dim nLookup As String[/TD]
[/TR]
[TR]
[TD="colspan: 2"]Dim i As Integer[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="colspan: 3"]Set myApp = CreateObject("excel.application")[/TD]
[/TR]
[TR]
[TD="colspan: 3"]Set wk = myApp.Workbooks.Open("C:\Users\Home\Downloads\Movies2016.xlsm")[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="colspan: 3"]Question = Application.Transpose(ThisWorkbook.Worksheets("Sheet1").Range("A2:A" & Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row).Value)[/TD]
[/TR]
[TR]
[TD="colspan: 3"]nArray = Application.Transpose(Application.Transpose(wk.Worksheets("Sheet1").Range("A2:C" & wk.Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row).Value))[/TD]
[/TR]
[TR]
[TD="colspan: 3"]For i = 1 To UBound(Question)[/TD]
[/TR]
[TR]
[TD="colspan: 3"]nLookup = Application.WorksheetFunction.VLookup(Question(i), nArray, 3, 0)[/TD]
[/TR]
[TR]
[TD="colspan: 3"]ReDim Preserve Answer(1 To i)[/TD]
[/TR]
[TR]
[TD="colspan: 3"]Answer(i) = nLookup[/TD]
[/TR]
[TR]
[TD]Next i[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="colspan: 3"]Range("C2", Range("c2").Offset(UBound(Answer) - 1)).Value = Application.Transpose(Answer)[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]'Stop[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="colspan: 3"]myApp.DisplayAlerts = False[/TD]
[/TR]
[TR]
[TD]wk.Close[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="colspan: 2"]myApp.Quit[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]End Sub[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]