Looping through list box controls (1 Viewer)

[dmorgan20]

Morning All

Im seriously confusing myself

What my code currently does:
The code checks the values in 3 listboxes, the user adds items to the list box to check, the query then looks for data associated with each item and exports it to a new excel if it does NOT match.

It will then check the second item in the list box and do the same process again.

Each exports opens in a brand new excel.

What I now need to achieve:
I want to be able to do the exact same above, but ultimately have all the data shown in just 1 excel file, instead of one file for each item in the listbox.

Column A is always a unique number.

Code:

Dim Lists(2) As Variant
Dim Tables(2) As Variant
Dim FitID As String
Dim i As Long
Dim l As Long
Dim c As Control
Dim SDict As Dictionary
Dim FDict As Dictionary
Dim WDict As Dictionary
Dim rs As Recordset
Dim SELECTItem As String
Dim SELECTString As String
Dim FROMString As String
Dim WHEREString As String
Dim vkey As Variant
Dim joinCount As Long
Dim toggle As Boolean
Dim DoesNotMatch As String
Dim sql As String: sql = ""
'Dim ReportCheck As Boolean
'Dim StatusFITID As String
'On Error GoTo ErrorCatch
If MsgBox("Are you sure you want to run the report?", vbYesNo) = vbNo Then Exit Sub
       
DoCmd.Hourglass True
    
                
'This finds out which column List has been ticked
    Select Case True
    Case Me.CFRCheck
        Lists(0) = "CFRMissMatchList"
        Tables(0) = "CFR"
        FitID = "[CFR].[Extension reference] AS FullFITID"
        'StatusFITID = "[CFR].[Extension reference]"
    Case Me.DatabaseCheck
        Lists(0) = "DatabaseMissMatchList"
        Tables(0) = "Database"
        FitID = "[Database].FullFITID"
        'StatusFITID = "[Database].FullFITID"
    Case Me.CSCheck
        Lists(0) = "CSMissMatchList"
        Tables(0) = "CS"
        FitID = "[CS].[FIT ID] AS FullFITID"
        'StatusFITID = "[CS].[FIT ID]"
    Case Else
        GoTo UserError
    End Select
    
'This then loops then controls on the form to find the other missmatch listboxes and checks that the listcount is the same as the ticked list.
    i = 1
    For Each c In Controls
        If c.Tag = "LoopMe" Then
            If c.Name <> Lists(0) Then
                If Not IsNull(Me.Controls(c.Name).ItemData(0)) Then
                    Lists(i) = c.Name
                    Tables(i) = Left(c.Name, InStr(1, c.Name, "Miss") - 1)
                    If Me.Controls(c.Name).ListCount <> Me.Controls(Lists(0)).ListCount Then GoTo UserError
                End If
                i = i + 1
                If i = 3 Then Exit For
            End If
        End If
    Next
    
'If data only in one list stop.
    If Lists(1) = "" And Lists(2) = "" Then GoTo UserError
    
'Loop the main list looping through tables creating SELECT String then move to excel
    For i = 0 To Me.Controls(Lists(0)).ListCount - 1
    
        Set SDict = New Dictionary
        Set FDict = New Dictionary
        Set WDict = New Dictionary
    
        For l = 0 To UBound(Lists)
            If Lists(l) <> "" Then
            
'Check if the selected column shows in the custom validation table. If so add the validation
                Set rs = CurrentDb.OpenRecordset("SELECT * FROM CustomValidation WHERE Report = '" & Tables(l) & "' AND ColumnName = '" & Me.Controls(Lists(l)).ItemData(i) & "'")
                If Not rs.EOF Then
                    SELECTItem = Replace(rs("Rule"), "var", "[" & Tables(l) & "].[" & rs("ColumnName") & "]") & ""
                    SELECTItem = Replace(SELECTItem, "|", "")
                Else
                    SELECTItem = "[" & Tables(l) & "].[" & Me.Controls(Lists(l)).ItemData(i) & "]"
                End If
                
'Create Dictionaries of needed items for the SQL
                If Not SDict.Exists(SELECTItem) Then
                    SDict.Add SELECTItem, SELECTItem & " AS " & Tables(l) & "Data"
                End If
                
                If Not WDict.Exists(SELECTItem) Then
                    WDict.Add SELECTItem, SELECTItem
                End If
                
                If Not FDict.Exists(SELECTItem) And l <> 0 Then
                    Select Case Tables(l)
                    Case Is = "CFR"
                        FROMString = "LEFT JOIN [CFR] ON " & JoinItem(CStr(Tables(0))) & " = " & JoinItem("CFR") & " "
                    Case Is = "CS"
                        FROMString = "LEFT JOIN [CS] ON " & JoinItem(CStr(Tables(0))) & " = " & JoinItem("CS") & " "
                    Case Is = "Database"
                        FROMString = "LEFT JOIN " & DBData(Me.Controls(Lists(l)).ItemData(i)) & " ON " & JoinItem(CStr(Tables(0))) & " = " & JoinItem("Database") & " "
                    End Select
                    If Not FDict.Exists(FROMString) Then
                        FDict.Add FROMString, FROMString
                    End If
                End If
                
            End If
        Next l
        
'Create the SQL string
        SELECTString = "SELECT DISTINCT " & FitID
        For Each vkey In SDict.Keys
            SELECTString = SELECTString & ", " & SDict(vkey)
        Next
        
        
'REMOVED as takes way too long!
'Simon add if here to add Database satus based onFirst FitId
'        If Me.StatusCheck = True Then
'            'SELECTString = SELECTString & ", AddStatus(" & StatusFITID & ") AS DatabaseStatus"
'
'            SELECTString = SELECTString & ", (SELECT TOP 1 status.description " _
'                                            & "FROM (statusCodes " _
'                                            & "INNER JOIN installation ON statusCodes.installationID = installation.installationID) " _
'                                            & "INNER JOIN status ON  (statusCodes.StatusID = status.StatusID AND status.statusGroup = 'registration') " _
'                                            & "WHERE 'FIT' & installation.FITID & '-' & installation.ExtensionReference = " & StatusFITID & " AND statusCodes.StatusGroup = 'registration' " _
'                                            & "ORDER BY RecordID DESC, dateOfChange DESC) AS DatabaseStatus"
'
'
'        End If
        Debug.Print SELECTString
        
        If Tables(0) = "Database" Then
            FROMString = "FROM (" & DBData(Me.Controls(Lists(0)).ItemData(i))
        Else
            FROMString = "FROM ([" & Tables(0) & "]"
        End If
        
        joinCount = 0
        For Each vkey In FDict.Keys
            joinCount = joinCount + 1
            FROMString = FROMString & " " & FDict(vkey) & ")"
        Next
        If joinCount = 2 Then FROMString = Left(FROMString, Len(FROMString) - 1)
        Debug.Print FROMString
        
        WHEREString = "WHERE "
        toggle = False
        For Each vkey In WDict.Keys
            If toggle = False Then
                DoesNotMatch = WDict(vkey) & " <> "
                toggle = True
            Else
                WHEREString = WHEREString & DoesNotMatch & WDict(vkey) & " OR "
            End If
        Next
        WHEREString = Left(WHEREString, Len(WHEREString) - 4)
        Debug.Print WHEREString


        If ReportCheck = True Then
            sql = sql & " SELECT"
            sql = sql & "   [FullFITID] AS FITS"
            sql = sql & " LEFT JOIN"
            sql = sql & "   (SELECTString & " & " & FROMString & " & " & WHEREString)"
            sql = sql & " ON"
            sql = sql & "   Me.Controls(Lists(0)).ItemData(i)"
        End If
        
        Debug.Print sql
    
   
    
'Export the query to Excel
        ExportQuery SELECTString & " " & FROMString & " " & WHEREString, True, Me.Controls(Lists(0)).ItemData(i)
    
    Next i
    
    MsgBox "All reports have been exported."
    
    DoCmd.Hourglass False
    Exit Sub
    
ErrorCatch:
If MsgBox("Error running - " & Me.Controls(Lists(0)).ItemData(i) & "." & vbCrLf & vbCrLf & Err.Description & vbCrLf & vbCrLf & "Carry on running reconcilation reports?", vbYesNo) = vbYes Then
    Resume Next
End If
DoCmd.Hourglass False
Exit Sub
UserError:
MsgBox "Please make sure you have data in at least 2 'Miss-Match' columns and that all list with data have the same amount of items selected."
DoCmd.Hourglass False
End Sub

The Export:

Public Sub ExportQuery(Query As String, ShowToUser As Boolean, Optional TabName As String)
'This will export a query to Excel and display it, or save it to a path if requested.
Dim rst As DAO.Recordset
Dim xlApp As Excel.Application
Dim i As Long
    Set xlApp = New Excel.Application
    
    Set rst = CurrentDb.OpenRecordset(Query, dbOpenDynaset, dbSeeChanges)
    
    With xlApp
    
    .Visible = ShowToUser
    .Workbooks.Add
    .Sheets("Sheet1").Select
    .Sheets("Sheet1").Range("A2").CopyFromRecordset rst
    
    For i = 1 To rst.Fields.Count
        xlApp.Sheets("Sheet1").Cells(1, i).Value = rst.Fields(i - 1).Name
    Next i
   ' xlApp.Cells.EntireColumn.AutoFitk
    End With
    
    If Not TabName = "" Then
        xlApp.ActiveSheet.Name = TabName
    End If
End Sub

As always, any help is appreciated

 

[arnelgp]

move Excel.Application Object to the first module and
add an Excel.Workbook object variable.

change the first subroutine. put this before the first Loop (i variable):

Dim xlApp As New Excel.Application
Dim xlWB As Object

then inside the loop, change this:

...
...
   
'Export the query to Excel
        ExportQuery SELECTString & " " & FROMString & " " & WHEREString, True, Me.Controls(Lists(0)).ItemData(i), i, xlApp, xlWB
    
    Next i
...
...

the export routine:

Public Sub ExportQuery(ByVal Query As String, ByVal ShowToUser As Boolean, ByVal TabName As String, ByVal TabCount As Integer, ByRef xlApp As Excel.Application, ByRef xlWB As Object)
'This will export a query to Excel and display it, or save it to a path if requested.
Dim rst As DAO.Recordset
Dim xlSh As Excel.Worksheet
Dim i As Long
    
    Set rst = CurrentDb.OpenRecordset(Query, dbOpenDynaset, dbSeeChanges)
    
    With xlApp
    
        .Visible = ShowToUser
        If TabCount < 1 Then
            Set xlWB = .Workbooks.Add
        
        Else
            Set xlSh = xlWB.Worksheets(xlWB.Worksheets.Count)
            xlWB.Worksheets.Add After:=xlSh
        End If
    End With
    Set xlSh = xlWB.Worksheets(xlWB.Worksheets.Count)
    With xlSh
        .Name = TabName
        .Select
        .Range("A2").CopyFromRecordset rst
    
         For i = 1 To rst.Fields.Count
             .Cells(1, i).Value = rst.Fields(i - 1).Name
         Next i
        ' xlApp.Cells.EntireColumn.AutoFitk
    End With
    
End Sub

not yet tested, you have to and give feedback
if working or not.

 

[CJ_London]

A bit confused by your description - code seems unnecessarily complex for something relatively simple. Why three separate listboxes? why does user add to listboxes? why is there a need for the checkboxes? How does a user add to the listbox (i.e. what functionality - select from another list, manual entry)? Perhaps provide some more background on what the user is doing.

I can see the purpose (Data cleansing?) is to provide a list of potential mismatches but why can this not be handled in a query? why the need for user intervention?

It looks like user selects a listbox to process and the code processes it, so suspect your ultimate solution will be to loop through all listboxes in one process and keep the excel object open until finished - or perhaps to reopen an existing file, if one has been previously been saved - matters since the user saves from excel, not access

is that 1 excel sheet as well? or one sheet for each listbox?

 

[dmorgan20]

@Arnelgp - Brilliant!!! This has now got the data going in to its own tabs, thank you very much.

To add a curve ball, how would we add it all on to a single excel sheet, for each loop it adds the mismatches to the corresponding ID in column A

@CJ_Long - Thank you for the comment, the code was written by someone who is no longer with us and we need to change how it operates.

Apologies about the poor description, to explain a bit better (hopefully)

The user interface has 3 list boxes with the headers from 3 different tables (headers are different in each table and its something we can change).

The user adds items to each list box for what they want to run the mismatch on (table 1 might have a header called 'address', table 2 might be 'addr' table 3 may say 'add')

The report is then run and it throws out one new excel document for the number of items in the listbox

What we want is if someone runs a report on 4 items then a new excel spreadsheet opens and populates the data column by column we can see all mismatches on each ID, rather than working the ID, then finding there is another mismatch on another item later on.

The reason for the check box is so the user can select which table is the main table, and the other two are then compared against the table that's selected using the check box

Hopefully that makes sense?

 

[arnelgp]

what do you mean? on the resulting workbook, do you want to combine all sheets into one? if you give me sample db with your modified code, then i will understand it better.

 

[CJ_London]

you have a solution from Arnel, but thanks for the more detailed explanation -I assume 'The user adds items to each list box for what they want to run the mismatch on' means they select a single field name from each list.

In which case why not just have a mapping table? or are you saying that Addr1 in table1 might be mapped to 'Address0' or 'Address1' in table2? Which can still be handled in a mapping table, just a little bit more complex.