Quantcast
Viewing latest article 2
Browse Latest Browse All 6

Nested Ifs Or Select Case?

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)


Viewing latest article 2
Browse Latest Browse All 6

Trending Articles