Salve a tutti,
una richiesta semplice se possibile.
In sintesi ho un codice VBA ,riprodotto da altri , che utilizza due combobox , le quali vengono pololate attraverso un altro codice vba "upload" che estrae i dati di un data base di un file esterno.
il codice funziona bene in tutte le sue parti ma si pone il seguente il problema :
tutte e due le combobox visualizzano tutti i dati delle colonne ad esse associate , mentre vorrei che la combobox "SO"(la 2°) visualizasse solo i dati filtrati dal dato scelto nella combobox "status".
il codice VBA è il seguente
Private Sub cmbStatus_Change()
End Sub
'SE NN FUNZIONA PROVARE A METTERE LA COLONNA SO VICINO A QUELLA STATUS
'questa subroutine cancella e resetta i dati
Private Sub cmdReset_Click()
'cancello le command_box
Sheets("View").Select
Sheets("View").Visible = True
'Sheets("View").Select
cmbStatus.Clear
cmbSO.Clear
'faccio in modo che il codice selezioni la pagina 'View' e le caselle
'dove inserire i dati
Range("E22:K22").Select
'Range("dataSet").Select
'cancella anche i dati che si sono caricati
Range(Selection, Selection.End(xlDown)).ClearContents
End Sub
'questa subroutine definisce cosa accade se clicco il pulsante show data
Private Sub cmdShowData_Click()
'strSQL sta per stringa definita con il Structured Query Language, cioè
'quello che riempirà la mia tabella dei dati
strSQL = "SELECT * FROM [data$] WHERE"
If cmbStatus.Text <> "" Then
'le parentesi quadre dovrebbero dire al computer che 'Status' è una classe
strSQL = strSQL & " [Status]='" & cmbStatus.Text & "'"
End If
If cmbSO.Text <> "" Then
If cmbStatus.Text <> "" Then
strSQL = strSQL & " AND [SO]='" & cmbSO.Text & "'"
Else
strSQL = strSQL & " [SO]='" & cmbSO.Text & "'"
End If
End If
'qui estraggo i dati e voglio specificare che non tutte le comboBox devono essere
'necessariamente piene, basta che una sola sia diversa da 'vuoto'
If cmbStatus.Text <> "" Or cmbSO.Text <> "" Then
'ora estraggo i dati (stringhe più o meno fisse da copiare)
closeRS
OpenDB
rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
'ora va a vedere i dati nella pagina 'data'
If rs.RecordCount > 0 Then
'qui ripeto i codici anche se li avevo messi già nella subroutine Reset perchè una
'volta che una subroutine viene chiusa, tutti i codici dentro muoiono per il sistema
Sheets("View").Visible = True
Sheets("View").Select
Range(Selection, Selection.End(xlDown)).ClearContents
'questo è il codice che finalmente mi copia tutti i dati che voglio riportare
ActiveCell.CopyFromRecordset rs
' se nella tabella dati non trova nessun risultato dai un messaggio di errore dove
'compare anche un triangolo giallo e il tasto ok
Else
MsgBox "I was not able to find any matching records.", vbExclamation + vbOKOnly
Exit Sub
End If
End If
End Sub
'subroutine che dice cosa fa il tasto upload
Private Sub cmdUpload_Click()
strSQL = "Select distinct [Status] from [data$] Order by [Status] "
closeRS
OpenDB
cmbStatus.Clear
rs.Open strSQL, cnn, adOpenKeyset, adLockPessimistic
If rs.RecordCount > 0 Then
Do While Not rs.EOF
cmbStatus.AddItem rs.Fields("Status").Value & ""
rs.MoveNext
Loop
Else
MsgBox "I was not able to find any unique Products.", vbCritical + vbOKOnly
Exit Sub
End If
'----------------------------------------------------------------------------------
strSQL = "Select distinct [SO] from [data$] Order by [SO] "
closeRS
OpenDB
cmbSO.Clear
rs.Open strSQL, cnn, adOpenKeyset, adLockPessimistic
If rs.RecordCount > 0 Then
Do While Not rs.EOF
cmbSO.AddItem rs.Fields("SO").Value & ""
rs.MoveNext
Loop
Else
MsgBox "I was not able to find any unique Products.", vbCritical + vbOKOnly
Exit Sub
End If
End Sub
questo invece è il codice che ricerca il file (esterno) nel quale è presente il database
Option Explicit
Public cnn As New ADODB.Connection
Public rs As New ADODB.Recordset
Public strSQL As String
Public Sub OpenDB()
If cnn.State = adStateOpen Then cnn.Close
cnn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};DBQ=C:\Users\Mas\Desktop\esercizi\MODS.xlsm"
cnn.Open
End Sub
Public Sub closeRS()
If rs.State = adStateOpen Then rs.Close
rs.CursorLocation = adUseClient
End Sub
grazie in anticipo