Lookup in closed workbook

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Lookup in closed workbook

Post by YasserKhalil »

Hello everyone
I have written the following code to lookup and match items in closed workbook and grab specific columns from the closed wworkbook

Code: Select all

Const cols As String = "13,14,2,3,4"

Sub Test()
    Dim a, x, ws As Worksheet, pt As String, r As Long, j As Long
    
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("Sheet1")
        a = Split(cols, ",")
            
        Rem Use This If You Need To Let The User Select The File
        With Application.FileDialog(msoFileDialogFilePicker)
            .Title = "Select The Data File"
            .AllowMultiSelect = False
            .InitialFileName = "E:\1\New Folder\To be rec\"
            If .Show <> -1 Then Exit Sub
            pt = .SelectedItems(1)
        End With
            
        With GetObject(pt)
            For r = 2 To ws.Cells(Rows.Count, 2).End(xlUp).Row
                With .Sheets(1)
                    x = Application.Match(ws.Cells(r, 2).Value, .Columns(1), 0)
                    If Not IsError(x) Then
                        ReDim w(UBound(a))
                        For j = LBound(w) To UBound(w)
                            w(j) = .Cells(x, Val(a(j))).Value
                        Next j
                        ws.Range("C" & r).Resize(1, UBound(a) + 1).Value = w
                    End If
                End With
            Next r
            .Close 0
        End With
    Application.ScreenUpdating = True
    
    MsgBox "Done...", 64
End Sub
It works for small amounts of data with no problem but excel hangs when dealing with large amounts of data
Is there any ideas to improve the speed of such code?
You do not have the required permissions to view the files attached to this post.

User avatar
HansV
Administrator
Posts: 78237
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Lookup in closed workbook

Post by HansV »

Is this faster?

Code: Select all

Sub Test2()
    Dim cn    As Object ' ADODB.Connection
    Dim rs    As Object ' ADODB.Recordset
    Dim sq    As String
    Dim arIn1 As Variant
    Dim arIn2 As Variant
    Dim arOut As Variant
    Dim pt    As String
    Dim ws    As Worksheet
    Dim m     As Long
    Dim r     As Long
    Dim s     As Variant
    Dim c     As Long
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select The Data File"
        .AllowMultiSelect = False
        .InitialFileName = "E:\1\New Folder\To be rec\"
        If .Show <> -1 Then Exit Sub
        pt = .SelectedItems(1)
    End With
    Set cn = CreateObject("ADODB.Connection")
    cn.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & _
        pt & "';" & "Extended Properties=""Excel 12.0;HDR=YES;IMEX=1;"";"
    Set rs = CreateObject("ADODB.Recordset")
    sq = "SELECT [Reference] " & _
        "FROM [Sheet1$] ORDER BY [Reference]"
    rs.Open Source:=sq, ActiveConnection:=cn, Options:=1
    arIn1 = rs.GetRows
    rs.Close
    sq = "SELECT [Clearing Document],[Payment Block],[Document Number],[Document Type],[Account] " & _
        "FROM [Sheet1$] ORDER BY [Reference]"
    rs.Open Source:=sq, ActiveConnection:=cn, Options:=1
    arIn2 = rs.GetRows
    rs.Close
    cn.Close
    Set ws = ThisWorkbook.Worksheets(1)
    m = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
    arOut = ws.Range("B1:G" & m).Value
    For r = 2 To m
        s = Application.Match(arOut(r, 1), arIn1, 0)
        If Not IsError(s) Then
            For c = 1 To 5
                arOut(r, c + 1) = arIn2(c - 1, s - 1)
            Next c
        End If
    Next r
    Application.ScreenUpdating = False
    ws.Range("B1:G" & m).Value = arOut
End Sub
Best wishes,
Hans

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Lookup in closed workbook

Post by YasserKhalil »

Thanks a lot Mr. Hans
Is there a way to have the needed columns as constant as in my code so as to avoid hard-coding the headers in the sq variable?

User avatar
HansV
Administrator
Posts: 78237
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Lookup in closed workbook

Post by HansV »

Why?
Best wishes,
Hans

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Lookup in closed workbook

Post by YasserKhalil »

As the needed columns would be changeable. I mean the code will be run several times with different columns each time. Is there an easy way to overcome that point? All what I could do in my code is to create a constant of columns as numbers and this can be changed easily.

User avatar
HansV
Administrator
Posts: 78237
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Lookup in closed workbook

Post by HansV »

You could use the values in C1, D1 etc. as arguments, if those names correspond to the names in the source file.
Best wishes,
Hans

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Lookup in closed workbook

Post by YasserKhalil »

How can we list the headers from the closed workbook using the ADO approach ...?
I am thinking of populating the headers into listbox on userfrom so as to let the user select the needed columns ..

User avatar
HansV
Administrator
Posts: 78237
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Lookup in closed workbook

Post by HansV »

You could first open a recordset on sq = "SELECT * FROM [Sheet1$]".
That allows you to read the field names.
Best wishes,
Hans

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Lookup in closed workbook

Post by YasserKhalil »

I tried this code but prints only the Reference title

Code: Select all

    Dim iCols As Integer
    For iCols = 0 To rs.Fields.Count - 1
        Debug.Print rs.Fields(iCols).Name
    Next iCols

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Lookup in closed workbook

Post by YasserKhalil »

That's my try (please correct me if there is incorrect lines)

Code: Select all

Sub ShowFormToSelectColumns()
    Dim cn As Object, rs As Object, sq As String, pt As String, iCol As Integer
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select The Data File"
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.Path & "\"
        If .Show <> -1 Then Exit Sub
        pt = .SelectedItems(1)
    End With
    Set cn = CreateObject("ADODB.Connection")
    cn.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & pt & "';" & "Extended Properties=""Excel 12.0;HDR=YES;IMEX=1;"";"
    Set rs = CreateObject("ADODB.Recordset")
    sq = "SELECT * FROM [Sheet1$]"
    rs.Open Source:=sq, ActiveConnection:=cn, Options:=1
    rs.Close
    For iCol = 0 To rs.Fields.Count - 1
        With UserForm1.ListBox1
            .AddItem rs.Fields(iCol).Name
        End With
    Next iCol
    UserForm1.Show
End Sub

User avatar
HansV
Administrator
Posts: 78237
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Lookup in closed workbook

Post by HansV »

Does it work?
Best wishes,
Hans

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Lookup in closed workbook

Post by YasserKhalil »

Yes it works for me .. and in the userform I created a commandbutton and listbox to let the user select the columns he need to grab

Code: Select all

Private Sub cmdOK_Click()
    Dim i As Long
    colNames = Empty
    With Me.ListBox1
        For i = 0 To .ListCount - 1
    If .Selected(i) = True Then
            colNames = colNames & "[" & ListBox1.List(i, 0) & "], "
            End If
        Next i
    End With
    If colNames <> Empty Then colNames = Mid(colNames, 1, Len(colNames) - 2) Else MsgBox "You Have To Select At Least One Column", vbExclamation
End Sub
But there is a problem for me which is the order of columns I need to deal with come with the same order as the Data file ... Is there a workaround to order the columns I selected from the listbox as I need to order?

User avatar
HansV
Administrator
Posts: 78237
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Lookup in closed workbook

Post by HansV »

The column names are listed in the order they are in the data file, so I don't understand.
Best wishes,
Hans

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Lookup in closed workbook

Post by YasserKhalil »

I mean in the last code that put in the userform the variable colNames is stored in the order of the headers but I need specific order like that
[Clearing Document],[Payment Block],[Document Number],[Document Type],[Account]

User avatar
HansV
Administrator
Posts: 78237
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Lookup in closed workbook

Post by HansV »

You could make the list box single-select.
Create a second list box, and two command buttons with captions 'Add >>' and '<< Remove'.
Clicking 'Add >>' would move the item selected in the first list box to the second one, and clicking '<< Remove' would remove the item selected in the second list box back to the first one. The user can click the items in the order they want.
Best wishes,
Hans

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Lookup in closed workbook

Post by YasserKhalil »

Thanks a lot. I had the idea before reading the post but in a little different way. I created two listboxes and relied on the double click to add or remove the items from the listbox

Code: Select all

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Me.ListBox2.AddItem Me.ListBox1.List(ListBox1.ListIndex)
    Me.ListBox1.RemoveItem Me.ListBox1.ListIndex
End Sub

Private Sub ListBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Me.ListBox1.AddItem ListBox2.List(ListBox2.ListIndex)
    Me.ListBox2.RemoveItem Me.ListBox2.ListIndex
End Sub

Private Sub cmdOK_Click()
    Dim i As Long
    colNames = Empty
    With Me.ListBox2
        For i = 0 To .ListCount - 1
            colNames = colNames & "[" & ListBox2.List(i, 0) & "], "
        Next i
    End With
    If colNames <> Empty Then colNames = Mid(colNames, 1, Len(colNames) - 2) Else MsgBox "You Have To Select At Least One Column", vbExclamation
End Sub

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Lookup in closed workbook

Post by YasserKhalil »

This is the final code in the standard module

Code: Select all

Public colNames As String

Sub FinalCode()
    Dim arIn1, arIn2, arOut, s, ws As Worksheet, cn As Object, rs As Object, sq As String, pt As String, iCol As Integer, m As Long, r As Long, c As Long
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select The Data File"
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.Path & "\"
        If .Show <> -1 Then Exit Sub
        pt = .SelectedItems(1)
    End With
    Set cn = CreateObject("ADODB.Connection")
    cn.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & pt & "';" & "Extended Properties=""Excel 12.0;HDR=YES;IMEX=1;"";"
    Set rs = CreateObject("ADODB.Recordset")
    sq = "SELECT * FROM [Sheet1$]"
    rs.Open Source:=sq, ActiveConnection:=cn, Options:=1
    rs.Close
    For iCol = 0 To rs.Fields.Count - 1
        With UserForm1.ListBox1
            .AddItem rs.Fields(iCol).Name
        End With
    Next iCol
    UserForm1.Show
    If colNames <> Empty Then
        sq = "SELECT [Reference] " & "FROM [Sheet1$] ORDER BY [Reference]"
        rs.Open Source:=sq, ActiveConnection:=cn, Options:=1
        arIn1 = rs.GetRows
        rs.Close
        sq = "SELECT " & colNames & " FROM [Sheet1$] ORDER BY [Reference]"
        rs.Open Source:=sq, ActiveConnection:=cn, Options:=1
        arIn2 = rs.GetRows
        rs.Close
        cn.Close
        Set ws = ThisWorkbook.Worksheets(1)
        m = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
        arOut = ws.Range("B1:G" & m).Value
        For r = 2 To m
            s = Application.Match(arOut(r, 1), arIn1, 0)
            If Not IsError(s) Then
                For c = 1 To 5
                    arOut(r, c + 1) = arIn2(c - 1, s - 1)
                Next c
            End If
        Next r
        Application.ScreenUpdating = False
        ws.Range("B1:G" & m).Value = arOut
    End If
End Sub
But I couldn't fix the rest of the code .. as I ecountered error at this line

Code: Select all

arOut(r, c + 1) = arIn2(c - 1, s - 1)
When I tried to select just two columns ..

User avatar
HansV
Administrator
Posts: 78237
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Lookup in closed workbook

Post by HansV »

Double-clicking should work too. Don't forget to display an instruction on the userform that selecting/removing fields is done by double-clicking.
Best wishes,
Hans

User avatar
HansV
Administrator
Posts: 78237
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Lookup in closed workbook

Post by HansV »

You should change the line

Code: Select all

                For c = 1 To 5
to

Code: Select all

                For c = 1 To UserForm1.ListBox2.ListCount
or something like that.
Best wishes,
Hans

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Lookup in closed workbook

Post by YasserKhalil »

But I have put the line `Unload Me` after getting the colNames variable and even if I comment out the line the code didin't work and no errors.