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)
