Lookup in closed workbook

[HansV]

You might put the number of items in a public variable, just like colNames.
Set the value of this variable in cmdOK_Click, and use it in FinalCode.

[YasserKhalil]

To avoid confusion here's the code in the userform I am using now

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
    Set aCols = Nothing
    With Me.ListBox2
        ReDim aCols(0 To .ListCount - 1)
        For i = 0 To .ListCount - 1
            aCols(i) = "[" & ListBox2.List(i, 0) & "]"
        Next i
    End With
    Debug.Print UBound(aCols)
    If UBound(aCols) = -1 Then MsgBox "You Have To Select At Least One Column", vbExclamation
    Unload Me
End Sub

And in the standard module

Code: Select all

Public aCols

Sub FinalCode()
    Dim arIn1, arIn2, arOut, s, ws As Worksheet, cn As Object, rs As Object, sq As String, pt As String, colNames 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 UBound(aCols) > 0 Then
        sq = "SELECT [Reference] " & "FROM [Sheet1$] ORDER BY [Reference]"
        rs.Open Source:=sq, ActiveConnection:=cn, Options:=1
        arIn1 = rs.GetRows
        rs.Close
        colNames = Join(aCols, ", ")
        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").Resize(m, UBound(aCols) + 2).Value
        For r = 2 To m
            s = Application.Match(arOut(r, 1), arIn1, 0)
            If Not IsError(s) Then
                For c = 1 To UBound(aCols) + 1
                    arOut(r, c + 1) = arIn2(c - 1, s - 1)
                Next c
            End If
        Next r
        Application.ScreenUpdating = False
        ws.Range("B1").Resize(m, UBound(aCols) + 2).Value = arOut
    End If
End Sub

The code seems to be working fine if I select more than a column but if I select only one column it doesn't work. Also I need to put the headers according to the selected headers ..

[HansV]

I will look at it when I get back home

[YasserKhalil]

Thanks a lot. Take your time.

[HansV]

Could you attach the workbook with the current version of the userform and code?

[YasserKhalil]

OK my tutor

[HansV]

Try this version:

Code: Select all

Sub FinalCode()
    Dim arIn1, arIn2, arOut, s, ws As Worksheet, cn As Object, rs As Object, sq As String, pt As String, colNames 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 UBound(aCols) >= 0 Then
        sq = "SELECT [Reference] " & "FROM [Sheet1$] ORDER BY [Reference]"
        rs.Open Source:=sq, ActiveConnection:=cn, Options:=1
        arIn1 = rs.GetRows
        rs.Close
        colNames = Join(aCols, ", ")
        sq = "SELECT " & colNames & " FROM [Sheet1$] ORDER BY [Reference]"
        rs.Open Source:=sq, ActiveConnection:=cn, Options:=1
        Set ws = ThisWorkbook.Worksheets(1)
        ws.Range("C:IV").Clear
        For iCol = 0 To rs.Fields.Count - 1
            ws.Cells(1, iCol + 3).Value = rs.Fields(iCol).Name
            Debug.Print rs.Fields(iCol).Name, rs.Fields(iCol).Type
            Select Case rs.Fields(iCol).Type
                Case 2, 3 ' asSmallInt, adInteger
                    ws.Cells(1, iCol + 3).EntireColumn.NumberFormat = "0"
                Case 4, 5 ' adSingle, adDouble
                    ws.Cells(1, iCol + 3).EntireColumn.NumberFormat = "#,#00.00"
                Case 7 ' adDate
                    ws.Cells(1, iCol + 3).EntireColumn.NumberFormat = "m/d/yyyy"
                Case Else
                    ws.Cells(1, iCol + 3).EntireColumn.NumberFormat = "@"
            End Select
        Next iCol
        arIn2 = rs.GetRows
        rs.Close
        cn.Close
        m = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
        arOut = ws.Range("B1").Resize(m, UBound(aCols) + 2).Value
        For r = 2 To m
            s = Application.Match(arOut(r, 1), arIn1, 0)
            If Not IsError(s) Then
                For c = 1 To UBound(aCols) + 1
                    arOut(r, c + 1) = arIn2(c - 1, s - 1)
                Next c
            End If
        Next r
        Application.ScreenUpdating = False
        With ws.Range("B1").Resize(m, UBound(aCols) + 2)
            .Value = arOut
            .EntireColumn.AutoFit
        End With
    End If
End Sub

[YasserKhalil]

Amazing my tutor. Thank you very much for great help in this topic.

[YasserKhalil]

Just one last point my tutor.
When I tested the code and didn't select any item from listbox1 then listbox2 is empty and at this case when I clicked OK I encountered an error at this line
ReDim aCols(0 To .ListCount - 1)
How to avoid such error and exit the whole sub ..?

[HansV]

Add a check on ListBox2.ListCount. If it is 0, exit cmdOK_Click.
In FinalCode, you can test whether aCols is empty.

[YasserKhalil]

I tried this .. It works for the part of the userform but as for aCols is empty in the standard module didn't work.

[HansV]

Since you set aCols to Nothing in cmdOK_Click, you should be able to use

Code: Select all

    If aCols Is Nothing Then Exit Sub

in FinalCode.

[YasserKhalil]

But in this case if I used
If aCols Is Nothing Then Exit Sub
then when selecting columns the error araised ..Object required

[YasserKhalil]

Instead of using

Code: Select all

Set aCols = Nothing 

I used this line that solved the problem

Code: Select all

aCols = Array()

Thank you very much for great helkp in this topic and for your patience.