Nima sent me his workbook, and I wrote the following code for him (it the code for a worksheet named View):
Private Sub OpenDB(ByRef cnn As ADODB.Connection) 'note the change between brackets ByRef cnn As... cnn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};DBQ=" & _ ActiveWorkbook.FullName cnn.Open End Sub ' Code to fill View worksheet with filtered records from Data worksheet Private Sub cmdShowData_Click() Dim strSQL As String Dim strWhere As String Dim cnn As New ADODB.Connection Dim rs As ADODB.Recordset Dim rng As Range Application.ScreenUpdating = False Set rs = New ADODB.Recordset 'create a new instance of the recordset 'populate data ============= strSQL = "SELECT Project, Container, Size, [Movement Type], HBL, MBL, Client, Vessel, Voyage, [Dis Date], DoDate, DoFee, Inpart, Line, [POL FWD], [MT Rtn], DMRG, [Settel Date] FROM [data$] " If cmbShptType.Text <> "" Then strWhere = strWhere & " AND [Movement Type] = '" & cmbShptType.Text & "'" End If If cmbLine.Text <> "" Then strWhere = strWhere & " AND [Line] = '" & cmbLine.Text & "'" End If If cmbPolFwd.Text <> "" Then strWhere = strWhere & " AND [POL FWD] = '" & cmbPolFwd.Text & "'" End If If cmbVsl.Text <> "" Then strWhere = strWhere & " AND [Vessel] = '" & cmbVsl.Text & "'" End If If cmbVoy.Text <> "" Then strWhere = strWhere & " AND [Voyage] = '" & cmbVoy.Text & "'" End If If txtArvF.Text <> "" Then strWhere = strWhere & " AND [DIS DATE] >= #" & Format(txtArvF.Text, "yyyy/mm/dd") & "#" End If If txtArvT.Text <> "" Then strWhere = strWhere & " AND [DIS DATE] <= #" & Format(txtArvT.Text, "yyyy/mm/dd") & "#" End If If txtDoF.Text <> "" Then strWhere = strWhere & " AND [DODATE] >= #" & Format(txtDoF.Text, "yyyy/mm/dd") & "#" End If If txtDoT.Text <> "" Then strWhere = strWhere & " AND [DODATE] <= #" & Format(txtDoT.Text, "yyyy/mm/dd") & "#" End If If txtRtnF.Text <> "" Then strWhere = strWhere & " AND [MT RTN] >= #" & Format(txtArvF.Text, "yyyy/mm/dd") & "#" End If If txtRtnT.Text <> "" Then strWhere = strWhere & " AND [MTN RTN] <= #" & Format(txtArvT.Text, "yyyy/mm/dd") & "#" End If If txtSettleF.Text <> "" Then strWhere = strWhere & " AND [SETTEL DATE] >= #" & Format(txtArvF.Text, "yyyy/mm/dd") & "#" End If If txtSettleT.Text <> "" Then strWhere = strWhere & " AND [SETTEL DATE] <= #" & Format(txtArvT.Text, "yyyy/mm/dd") & "#" End If If strWhere <> "" Then ' Drop the first " AND " strWhere = Mid(strWhere, 6) strSQL = strSQL & "WHERE " & strWhere End If Set cnn = New ADODB.Connection OpenDB cnn 'note that we have to add cnn rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic 'create the recordset Set cnn = Nothing 'dispose the connection and disconnect the recordset 'DO NOT close the connection here as it'll close the recordset as well Set rng = Range("Dataset").Offset(1) Range(rng, rng.End(xlDown)).ClearContents If rs.RecordCount > 0 Then 'Now putting the data on the sheet============= rng.Cells(1).CopyFromRecordset rs rng.Copy Range(rng, rng.End(xlDown)).PasteSpecial xlPasteFormats Application.CutCopyMode = False Range("A1").Select Else MsgBox "I was not able to find any matching records.", vbExclamation End If rs.Close Set rs = Nothing Application.ScreenUpdating = True Sheets("view").Cells.WrapText = False Sheets("view").Columns.ColumnWidth = 10 End Sub '============================================================= 'Updating Fields '============================================================= ' Code to populate some combo boxes on the View sheet Private Sub cmdUpdateDropDowns_Click() Dim cnn As New ADODB.Connection OpenDB cnn 'niFlag = 1 FillCombo Me.cmbShptType, "Movement Type", cnn FillCombo Me.cmbLine, "Line", cnn FillCombo Me.cmbPolFwd, "POL FWD", cnn FillCombo Me.cmbVsl, "Vessel", cnn FillCombo Me.cmbVoy, "Voyage", cnn cnn.Close Set cnn = Nothing End Sub Private Sub FillCombo(ByRef MyCombo As MSForms.ComboBox, ByVal FieldName As String, ByVal cnn As ADODB.Connection) Dim strSQL As String Dim rs As ADODB.Recordset strSQL = "Select Distinct [" & FieldName & "] From [data$] Order by [" & FieldName & "]" MyCombo.Clear Set rs = New ADODB.Recordset rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic Set cnn = Nothing If rs.RecordCount > 0 Then Do While Not rs.EOF If Not IsNull(rs.Fields(0)) Then MyCombo.AddItem rs.Fields(0) rs.MoveNext Loop Else MsgBox "I was not able to find any unique Products.", vbCritical Set rs = Nothing End If rs.Close Set rs = Nothing End Sub
Nima reported that he was able to use the code and to modify it slightly.
Regards, Hans Vogelaar (http://www.eileenslounge.com)