Formulation du code VBA sur les optionbuttons
Bonjour à tous et toutes je suis actuellement bloquer sur un programme VBA que j'ai mis pour alimenter un base de données au travers un formulaire cependant je suis bloquer au niveau de la formulation sur Optionbuttoon par rapport a la base de données et les colonne à remplir il est mieux que je vous fasse une capture d'écran les secteurs concernés par optionbutton SECTEURS CRT HT /BT et Secteur CRT TR, SECTEUR CM et SECTEUR THP/MPT
Ci dessous les options je souhaiterai pouvoir choisir un option et elle tombe directement dans l'une des colonnes nommées qui représentent le secteurs mais aujoudhui avec le code que j'ai mis lorsque je fais un choix il tombe sur les secteurs voir figure 1 pourriez vous m'aidez svp
le fichier est trop lourd
Bonjour
Tu devrais joindre ton fichier...
Bye !
le fichier est trop lourd justement sauf ci ya moyen de juste copier toute la macro
Voici mon code VBA
Option Explicit
'**************************************************'
'Afficher le formulaire à partir
'd'une feuille Excel
'**************************************************'
Private Sub TxtQUANTITEREALISEE_KeyPress(ByVal KeyAscii As MsForms.ReturnInteger)
'********************************************************************************
'Eviter les erreurs lors de la saisie du formulaire (point et virgule)
'********************************************************************************
' Vérifier si le caractère saisi est une virgule
Select Case KeyAscii
Case 44, 46 'que l'on frappe une virgule ou un point
If InStr(TxtQUANTITEREALISEE.Text, ",") Then 'si déjà une virgule présent
KeyAscii = 0 'on ne permet pas deux virgules
Else 'sinon
KeyAscii = 46 'on force le point et pas la virgule
End If
Case 48 To 57 'on laisse passer car ce sont des chiffres
Case Else
KeyAscii = 0 'on ne laisse pas passer
End Select
End Sub
Private Sub UserForm_Initialize()
'Bouton par défaut
LblNOMS = ""
TxtTEMPSPASSE = 420
TxtPause.Value = 20
'Secteur CRT HT BT
OptionButtonPréP.Value = True
OptionButtonPrépa.Value = False
OptionButtonBoBan.Value = False
OptionButtonBobVr.Value = False
OptionButtonMontageBT_HT.Value = False
'OptionButtonFerm.Value = False
OptionButtonDémoulageBT_HT.Value = False
OptionButtonBT1.Value = False
OptionButtonBT2.Value = False
OptionButtonBT3.Value = False
OptionButtonBT4.Value = False
OptionButtonBT5.Value = False
OptionButtonBT6.Value = False
OptionButtonBT7.Value = False
'Secteur CRT CM TR
OptionButtonCoupeBOTR.Value = False
OptionButtonRéparaTR.Value = False
OptionButtonConditionTR.Value = False
OptionButtonDébalTR.Value = False
OptionButtonEmpilTR.Value = False
OptionButtonFermTR.Value = False
OptionButtonPeintBridTR.Value = False
OptionButtonMontTR.Value = False
OptionButtonEssaiTR.Value = False
OptionButtonMCelluCTR.Value = False
OptionButtonFilerieTR.Value = False
OptionButtonContrôleTR.Value = False
OptionButtonRépTR.Value = False
'Secteur THP MPT
OptionButtonCartonTHP.Value = False
OptionButtonPrépaCouvTHP.Value = False
OptionButtonDéballageTHP.Value = False
OptionButtonMontHTBTTHP.Value = False
OptionButtonMiseEnCuvTHP.Value = False
OptionButtonFinitionAVESTHP.Value = False
OptionButtonFinitionAPESTHP.Value = False
OptionButtonBoBineBTTHP.Value = False
OptionButtonBoBineHTTHP.Value = False
OptionButtonEMpillageBTHTTHP.Value = False
OptionButtonFermTHP.Value = False
End Sub
Function GetColonne(optionButton As MsForms.optionButton) As Range
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("BDD Test (2)")
Dim optionButtonCaption As String
optionButtonCaption = optionButton.Caption ' Obtenez le texte du caption de l'OptionButton
Select Case optionButtonCaption
Case "Bobinage BT1": Set GetColonne = ws.Range("SECTEUR CRT HT BT")
Case "Bobinage BT2": Set GetColonne = ws.Range("SECTEUR CRT HT BT")
Case "Cartonnage THP": Set GetColonne = ws.Range("SECTEUR THP/MPT")
Case "PréparatCouvTHP": Set GetColonne = ws.Range("SECTEUR THP/MPT")
Case "Débalage CM THP": Set GetColonne = ws.Range("SECTEUR THP/MPT")
' Ajoutez d'autres cas pour d'autres options et colonnes ici si nécessaire
Case Else
' Si le caption de l'OptionButton ne correspond à aucune colonne, vous pouvez gérer cela ici
Set GetColonne = Nothing ' Par exemple, retournez Nothing pour indiquer qu'aucune colonne correspondante n'a été trouvée
End Select
End Function
'Function GetColonne(optionButton As MsForms.optionButton) As Range
'Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("BDD Test (2)")
'Dim optionButtonName As String
'optionButtonName = optionButton.Name ' Obtenez le nom du contrôle d'option en tant que chaîne
'Select Case optionButtonName
'Case "OptionButtonBT1": Set GetColonne = ws.Range("SECTEUR")
'Case "OptionButtonBT2": Set GetColonne = ws.Range("SECTEUR")
'Case "OptionButtonBT3": Set GetColonne = ws.Range("SECTEUR")
'Case "OptionButtonBT4": Set GetColonne = ws.Range("SECTEUR")
'Case "OptionButtonBT5": Set GetColonne = ws.Range("SECTEUR")
'Case "OptionButtonBT6": Set GetColonne = ws.Range("SECTEUR")
'Case "OptionButtonBT7": Set GetColonne = ws.Range("SECTEUR")
'Case "OptionButtonBT1": Set GetColonne = ws.Range("SECTEUR")
'Case "OptionButtonBT1": Set GetColonne = ws.Range("SECTEUR")
'Case "OptionButtonBT1": Set GetColonne = ws.Range("SECTEUR")
'Case "OptionButtonBT1": Set GetColonne = ws.Range("SECTEUR")
'Case "OptionButtonBT1": Set GetColonne = ws.Range("SECTEUR")
' Ajoutez d'autres cas pour les autres contrôles d'option ici si nécessaire
'End Select
'End Function
Private Sub BtnAJOUT_Click()
'**********************************************************************************************'
'Procédure permettant d'ajouter un nouvel enrégistrement dans la BDD
'**********************************************************************************************'
'************************************************************************************************
'CE QUI SE PASSE LORS DE L'AJOUT DES DONNEES DU "Formulaire de saisie" VERS LA FEUILLE "BDD Test"
'************************************************************************************************
'************************************************************************************************
'1 - Contrôle des champs manquants
'************************************************************************************************
If CboListeOpérateurs.Text = "" Then
MsgBox "Quel est le nom?", vbCritical, "Nom manquant"
CboListeOpérateurs.SetFocus
ElseIf TxtTEMPSGAMME.Text = "" Then
MsgBox "Quel est le temps gamme ?", vbCritical, "Temps gamme"
TxtTEMPSGAMME.SetFocus
ElseIf TxtTEMPSPASSE.Text = "" Then
MsgBox "Quel est le temps passé ?", vbCritical, "Temps passe"
TxtTEMPSPASSE.SetFocus
ElseIf TxtQUANTITEREALISEE.Text = "" Then
MsgBox "Combien de bobines ?", vbCritical, "Nombre de bobines"
TxtQUANTITEREALISEE.SetFocus
Else
'***************************************************************************************
'Calcul de la performance de profuction avec tous les temps rouges
'***************************************************************************************
'*************************************************************************
'2 - Calcul de l'EFFICACITE
'*************************************************************************
'Il s'agit calculer l'Efficacité,au travers des données tels que la Quantité; le Tpsgamme et le Tpspassé sont des "chaines" de chiffre (string)
'***********************************************************************************
'3 - Contrôle de la valeur de l'efficacité par l'opérateur
'***********************************************************************************
'Dim Rep As Integer
'Rep = MsgBox("Les déperditions sont elles correctes ? " & Déperdition & " min", vbYesNo + vbQuestion, "Verification")
'If Rep = vbNo Then
' traitement si réponse négative (focus sur quantité)
'TxtQUANTITEREALISEE.SetFocus
'Else
' ici le traitement si réponse positive
'***********************************************************************************
'ON REMPLI LES CHAMPS DE LA FEUILLE "BDD Test" via les renseignements du Formulaire
'***********************************************************************************
'On veut remplir uniquement les champs dans la dernière ligne du tableau
'On dit que le numéro de la ligne vide est un nombre entier
'Dim numlignevide As Integer
'on active la feuille "Base de Données (BDD Test)"
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("BDD Test (2)")
ws.Unprotect
ws.Activate
'On trouve la dernière ligne vide
'ActiveSheet.Cells = (numlignevide, 1).Find("").Row
Dim numlignevide As Long: numlignevide = ws.Cells(3, ws.[Date].Column).End(xlDown).Row + 1
'On active la cellule d'une colonne
'numlignevide = ActiveSheet.Columns(1).Find("").Row
'On veut la dernière ligne, de la colonne
'Et on rempli à partir des informations des cases de ouvrir Formulaire = Txttempsgamme.value
Dim currentRow As Range: Set currentRow = ActiveSheet.Rows(numlignevide)
Application.Intersect(currentRow, ws.[Noms]).Value = CboListeOpérateurs.Value
Application.Intersect(currentRow, ws.[Date]).Value = Format(TxtDATE.Value, "mm/dd/yyyy")
Application.Intersect(currentRow, GetColonne(ObtenirCaptionOptionButton)).Value = ObtenirCaptionOptionButton
Application.Intersect(currentRow, ws.[HORAIRES]).Value = CboHORAIRES.Value
Application.Intersect(currentRow, ws.[STATUT]).Value = CboSTATUT.Value
Application.Intersect(currentRow, ws.[EQUIPE]).Value = CboEQUIPE.Value
Application.Intersect(currentRow, ws.[TEMPSGAMME]).Value = TxtTEMPSGAMME.Value
Application.Intersect(currentRow, ws.[TEMPSPASSE]).Value = TxtTEMPSPASSE.Value
Application.Intersect(currentRow, ws.[QUANTITEREALISEE]).Value = TxtQUANTITEREALISEE.Value
Application.Intersect(currentRow, ws.[Efficacite]).Value = Format(TxtTEMPSGAMME.Value / TxtTEMPSPASSE.Value, "0%")
Application.Intersect(currentRow, ws.[Retouchebobine]).Value = TxtRetouchesBobines.Value
Application.Intersect(currentRow, ws.[REALISATION]).Value = TxtRéalisationDesjoints.Value
Application.Intersect(currentRow, ws.[CONTROLESB]).Value = TxtCTRLBobines.Value
Application.Intersect(currentRow, ws.[CONTROLEC]).Value = TxtCTRLCuves.Value
Application.Intersect(currentRow, ws.[CHANGEMENTDESERIE]).Value = TxtChangementDeSérie.Value
Application.Intersect(currentRow, ws.[MANQUEDECOMPOSANT]).Value = TxtManquants.Value
Application.Intersect(currentRow, ws.[RECHERCHEDESCOMPO]).Value = TxtRechercheDesComposants.Value
Application.Intersect(currentRow, ws.[Manutention]).Value = TxtManutention.Value
Application.Intersect(currentRow, ws.[NETOYAGEDEPOSTE]).Value = TxtNettoyageAuPoste5S.Value
Application.Intersect(currentRow, ws.[Formation]).Value = TxtFormation.Value
Application.Intersect(currentRow, ws.[Reunion]).Value = TxtRéunion.Value
Application.Intersect(currentRow, ws.[Pannes]).Value = TxtPannes.Value
Application.Intersect(currentRow, ws.[Pause]).Value = TxtPause.Value
Application.Intersect(currentRow, ws.[AIC_TIME]).Value = TxtAIC.Value
Application.Intersect(currentRow, ws.[IMPACTORG]).Value = TxtImpactOrg.Value
Application.Intersect(currentRow, ws.[CHANGEMENTDOUTIL]).Value = TextCHANGEMENTDOUTIL.Value
Application.Intersect(currentRow, ws.[MANQUANT]).Value = TxtManquants.Value
Application.Intersect(currentRow, ws.[Attenteconducteur]).Value = TxtAttenteconducteur.Value
Application.Intersect(currentRow, ws.[Attentegrillage]).Value = TxtAttenteGrillage.Value
Application.Intersect(currentRow, ws.[MAUVAISEOPERATION]).Value = TxtMauvaiseOpéra.Value
Application.Intersect(currentRow, ws.[RangementOutils]).Value = TxtRangementOutils.Value
Application.Intersect(currentRow, ws.[CONTROLEVANNE]).Value = TxtCTRLVannes.Value
Application.Intersect(currentRow, ws.[Composantdefectueux]).Value = TxtComposantdefectueux.Value
Application.Intersect(currentRow, ws.[Attente_Four]).Value = TxtAttentefour.Value
Application.Intersect(currentRow, ws.[REPARATIONTFO]).Value = TxtRéparationTRF.Value
Application.Intersect(currentRow, ws.[Rangementmoule]).Value = TxtRangementMoule.Value
Application.Intersect(currentRow, ws.[RangementOutils]).Value = TxtRangementOutils.Value
Application.Intersect(currentRow, ws.[TEMPSREACQUALI]).Value = TxtTempsRéacQualité.Value
Application.Intersect(currentRow, ws.[TEMPSREACMAINT]).Value = TxtTempsRéactMaint.Value
Application.Intersect(currentRow, ws.[PROBLEMEDIGI]).Value = TxtProblemDigi.Value
Application.Intersect(currentRow, ws.[IMPACTORG]).Value = TxtImpactOrg.Value
Application.Intersect(currentRow, ws.[PROBLEMEDIGI]).Value = TxtProblemDigi.Value
Application.Intersect(currentRow, ws.[PROBLEME_BE]).Value = TxtProblemBE.Value
Application.Intersect(currentRow, ws.[ATTENTECOMPO]).Value = TxtAttenteCOMPO.Value
Application.Intersect(currentRow, ws.[COORDINATIONAD]).Value = TxtCoordinationAD.Value
Application.Intersect(currentRow, ws.[COORDINATIONAT]).Value = TxtCoordinationAT.Value
Application.Intersect(currentRow, ws.[ECART_TPS_GM]).Value = TxtEcart_TMPS_GM.Value
Application.Intersect(currentRow, ws.[SECOND_PREP]).Value = TxtSecondPrep.Value
Application.Intersect(currentRow, ws.[MANQUECONX]).Value = TxtManque_Connexion.Value
Application.Intersect(currentRow, ws.[ATTENTE_PONT]).Value = TxtAttente_Ponts.Value
Application.Intersect(currentRow, ws.[REPARATIONTRF]).Value = TxtProcess_Fab.Value
Application.Intersect(currentRow, ws.[CONTROLE]).Value = TxtContrôle.Value
Application.Intersect(currentRow, ws.[ECRAN]).Value = TxtEcran.Value
Application.Intersect(currentRow, ws.[ATTENTE_PONT]).Value = TxtAttente_Ponts.Value
Application.Intersect(currentRow, ws.[PASSAGE_FOUR]).Value = Txtpassage_Four.Value
' ajout es lignes pour enregistrer le choix de l'OptionButton dans la colonne correspondante.
' Afficher un message de confirmation d'ajout dans la BDD Test (2)
MsgBox "informations enregistrées avec succès dans la base de données!", vbInformation
End If
End Sub
Function ObtenirCaptionOptionButton() As String
Dim ctrl As Control
For Each ctrl In Formulaire_Saisie.Controls
If TypeOf ctrl Is MsForms.optionButton Then
Dim OptButton As MsForms.optionButton
Set OptButton = ctrl
If OptButton.Value Then
ObtenirCaptionOptionButton = OptButton.Caption
Exit Function
End If
End If
Next
End Function
Function ObtenirOptionButton() As MsForms.optionButton
Dim ctrl As Control
For Each ctrl In Formulaire_Saisie.Controls
If TypeOf ctrl Is MsForms.optionButton Then
Dim OptButton As MsForms.optionButton
Set OptButton = ctrl
If OptButton.Value Then
Set ObtenirOptionButton = OptButton
Exit Function
End If
End If
Next
End Function
Private Sub txtDate_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If TxtDATE.Text = "" Then
TxtDATE.Text = Date
End If
End Sub
Private Sub TxtNOMS_Change()
If TxtNOMS <> "" Then
BtnAJOUT.Enabled = True 'Activer le bouton
Else
BtnAJOUT.Enabled = False 'Désactive le bouton
End If
End Sub
Private Sub TxtTEMPSPASSE_Change()
If TxtTEMPSPASSE <> "" Then
BtnAJOUT.Enabled = True 'Activer le bouton
Else
BtnAJOUT.Enabled = False 'Désactive le bouton
End If
End Sub
Private Sub BtnSOURCE_Click()
'*********************************************************'
'Procédure permettant d'accéder à la source de la BDD Test
'*********************************************************'
Sheets("BDD Test (2)").Activate
Range("A1").Select
End Sub
Private Sub BtnEFFACE_Click()
'****************************************'
'Procédure permettant Rénitialiser
'tous les champs du formulaire
'*****************************************'
'on efface le formulaire
CboSTATUT = ""
CboHORAIRES = ""
CboEQUIPE = ""
CboListeOpérateurs = ""
TxtNOMS = ""
TxtTEMPSGAMME = ""
TxtTEMPSPASSE = ""
TxtQUANTITEREALISEE = ""
TxtRetouchesBobines = ""
TxtRéalisationDesjoints = ""
TxtCTRLBobines = ""
TxtCTRLCuves = ""
TxtChangementDeSérie = ""
TxtManquants = ""
TxtRechercheDesComposants = ""
TxtManutention = ""
TxtNettoyageAuPoste5S = ""
TxtFormation = ""
TxtRéunion = ""
TxtPannes = ""
TxtPause = ""
TxtAIC = ""
TxtImpactOrg = ""
TextCHANGEMENTDOUTIL = ""
TxtManquants = ""
TxtAttenteconducteur = ""
TxtAttenteGrillage = ""
TxtMauvaiseOpéra = ""
TxtRangementOutils = ""
TxtCTRLVannes = ""
TxtComposantdefectueux = ""
TxtAttentefour = ""
TxtRéparationTRF = ""
TxtRangementMoule = ""
TxtRangementOutils = ""
TxtTempsRéacQualité = ""
TxtTempsRéactMaint = ""
TxtProblemDigi = ""
TxtImpactOrg = ""
TxtProblemDigi = ""
TxtProblemBE = ""
TxtAttenteCOMPO = ""
TxtCoordinationAD = ""
TxtCoordinationAT = ""
TxtEcart_TMPS_GM = ""
TxtSecondPrep = ""
TxtManque_Connexion = ""
TxtAttente_Ponts = ""
Txtpassage_Four = ""
'Désactiver le bouton Ajouter
BtnAJOUT.Enabled = False
'Réinitialiser les OptionButtons
InitializeOptionButtons
End Sub
Private Sub InitializeOptionButtons()
Dim ctrl As Control
For Each ctrl In Formulaire_Saisie.Controls
If TypeOf ctrl Is MsForms.optionButton Then
Dim OptButton As MsForms.optionButton
Set OptButton = ctrl
OptButton.Value = False
End If
Next
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'*********************************************************'
'Procédure permettant de vider les champs du formulaire
'*********************************************************'
Unload Me
End Sub