Sub Selector_Updater()
'Used to update the the Initiatives available for selection in the Initiative drop down
Dim adoCtn As ADODB.Connection
Dim adoRS As ADODB.Recordset
Dim wsSQL As String
Dim wsconn As String
Dim wsCount As Integer
Dim sOutput As String
Dim myCtl As Control
Dim SQL_Crit As String
Dim wsColumn As String
Dim x As Integer
Dim wsVarCou As Integer
Dim SQL_Cols As String
Dim wsInit_Concat As String
Dim wsList(1 To 50) As String
'Creates Required Columns
SQL_Cols = "ID, Title, Actioner"
'Creates Selection Criteria
SQL_Crit = ""
'Checks whether a control is a checkbox and whether it is true, if yes it picks up the value in the associated control
For Each myCtl In Me("Select_Criteria").Controls
If TypeName(myCtl) = "CheckBox" And myCtl = True Then
'picks up the field name
wsColumn = Right(myCtl.Name, Len(myCtl.Name) - 6)
If Me("Select_" & wsColumn) = "" Then
x = MsgBox("YOU HAVE NOT ENTERED A CRITERIA FOR" & vbNewLine & vbNewLine & wsColumn, vbOKOnly)
Exit Sub
End If
SQL_Crit = SQL_Crit & "[" & wsColumn & "] = '" & Me("Select_" & wsColumn) & "' AND "
End If
Next myCtl
If SQL_Crit = "" Then
Exit Sub
End If
SQL_Crit = Left(SQL_Crit, Len(SQL_Crit) - 5)
'Creates SQL String
wsSQL = "SELECT " & SQL_Cols & " FROM Gen_Info WHERE " & SQL_Crit
'Sets up wsConn with database path and connection details
wsconn = "DSN=MS Access Database;" & _
"DBQ=\\10.17.50.24\users$\wisimpson\Tracker\Initiative Tracker.accdb;" & _
"DriverId=25;FIL=MS Access;MaxBufferSize=2048;PageTimeout=5;"
'Creates and opens ADODB connection
Set adoCtn = New ADODB.Connection
adoCtn.Open wsconn
'Creates and setups up a record set
Set adoRS = New ADODB.Recordset
adoRS.Open Source:=wsSQL, ActiveConnection:=adoCtn
If Not (adoRS.BOF Or adoRS.EOF) Then 'If there are no records, this will be false
adoRS.MoveFirst 'This probably isn't necessary, particularly with the default
'cursor type,but I always include it anyway
wsCount = adoRS.Fields.Count
wsVarCou = 1
Do While Not adoRS.EOF Or adoRS.BOF 'Start looping through the records
x = 0
wsInit_Concat = ""
Do While x < wsCount
wsInit_Concat = wsInit_Concat & adoRS.Fields.Item(x).Value & " - "
x = x + 1
Loop
wsInit_Concat = Left(wsInit_Concat, Len(wsInit_Concat) - 3)
wsList(wsVarCou) = wsInit_Concat
wsVarCou = wsVarCou + 1
adoRS.MoveNext 'When your code has been running for 1/2 an hour, you
'probably forgot this line. I know I forget it all the time.
Loop
'Close stuff
adoRS.Close
adoCtn.Close
'Get rid of the last comma
' sOutput = Left(sOutput, Len(sOutput) - 1)
Else
sOutput = "Empty Recordset"
End If
'Output
Debug.Print sOutput
'Clean up
Set adoRS = Nothing
Set adoCtn = Nothing
Sheets("Referencing").Range("Init_list").Clear
Sheets("Referencing").Range("Init_list").Select
wsVarCou = 1
Do While wsList(wsVarCou) <> ""
ActiveCell.Value = wsList(wsVarCou)
ActiveCell(2, 1).Select
wsVarCou = wsVarCou + 1
Loop
Range("Init_list").Select
ActiveWorkbook.Names("Init_list").Delete
Range(ActiveCell, Selection.End(xlDown)).Select
ActiveWorkbook.Names.Add Name:="Init_list", RefersTo:=Selection
Init_Pick.RowSource = "=Init_list"
DoEvents
End Sub