Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

ListBox et copies Cellules

  • Initiateur de la discussion Initiateur de la discussion roby
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

roby

XLDnaute Occasionnel
bonjour le Forum,

La commande "Valider" n'arrive pas à mettre à jour certaines cellules de la feuille, pourtant les TextBox8 à TextBox11 sont bien renseignées dans la boite de dialogue.

ci-dessous le code:

Private Sub ComboBox1_Change() Correspond à un choix
'Cherche MU
'----------
Dim L3 As Integer
Dim ReCherche, LRecherche As String
Dim Plage3 As Range
Application.ScreenUpdating = False
Sheets("Dispositifs").Activate
ReCherche = APPSMJ.ComboBox1.Value
L3 = Sheets("Dispositifs").Range("F65536").End(xlUp).Row
Set Plage3 = Sheets("Dispositifs").Range("F9:F" & L3)
For Each Cell In Plage3
If Cell.Value = ReCherche Then
LRecherche = Cell.Row
Cell.Select
End If
Next Cell
APPSMJ.TextBox8.Value = Selection.Offset(0, 1).Value Les données recherchées
APPSMJ.TextBox9.Value = Selection.Offset(0, 2).Value
APPSMJ.TextBox10.Value = Selection.Offset(0, 3).Value
APPSMJ.TextBox11.Value = Selection.Offset(0, 4).Value
If Selection.Offset(0, 5).Value = "PSE" Then
APPSMJ.OptionButton5 = True
Else
APPSMJ.OptionButton4 = True
End If
Sheets("PPSMJ").Activate
Application.ScreenUpdating = True
APPSMJ.CommandButton1.SetFocus
End Sub

Private Sub CommandButton1_Click()
'Valider
'-------
Dim L1, L2, n As Integer
Dim Plage2 As Range
APPSMJ.CommandButton3.Enabled = True
If APPSMJ.TextBox1 = "" Then
MsgBox "ATTENTION, vous n'avez saisie aucune donnée !", vbCritical, "Saisie incomplète": Unload Me
On Error Resume Next: Err.Clear
End If
If Choix = 1 Then
L1 = Sheets("PPSMJ").Range("C65536").End(xlUp).Row + 1
Else
L1 = NomLBindex1
End If
With Sheets("PPSMJ")
.Range("A" & L1).Value = APPSMJ.TextBox1.Value
.Range("C" & L1).Value = APPSMJ.TextBox3.Value
.Range("D" & L1).Value = APPSMJ.TextBox4.Value
.Range("E" & L1).Value = APPSMJ.TextBox5.Value
.Range("F" & L1).Value = APPSMJ.TextBox6.Value
.Range("G" & L1).Value = APPSMJ.TextBox7.Value
If APPSMJ.OptionButton1 = True Then
.Range("H" & L1).Value = "H" 'Homme
End If
If APPSMJ.OptionButton2 = True Then
.Range("H" & L1).Value = "F" 'Femme
End If
If APPSMJ.OptionButton3 = True Then
.Range("H" & L1).Value = "M" 'Mineur
End If

.Range("I" & L1).Value = APPSMJ.ComboBox1.Value c'est ici qu'il ne veut pas copier
.Range("J" & L1).Value = APPSMJ.TextBox8.Value
.Range("K" & L1).Value = APPSMJ.TextBox9.Value
.Range("L" & L1).Value = APPSMJ.TextBox10.Value
.Range("M" & L1).Value = APPSMJ.TextBox11.Value

If APPSMJ.OptionButton5 = True Then
.Range("N" & L1).Value = "PSE"
Else
.Range("N" & L1).Value = "PSEM"
End If
End With

For n = 1 To 7
APPSMJ.Controls("TextBox" & n) = ""
Next n
APPSMJ.ComboBox1 = ""
For n = 8 To 11
APPSMJ.Controls("TextBox" & n) = ""
Next n
APPSMJ.OptionButton4 = False
APPSMJ.OptionButton5 = False
'Mise à jour - Dispositifs -> Dispo "N"
Application.ScreenUpdating = False
Sheets("Dispositifs").Activate
ReCherche = APPSMJ.ComboBox1.Value
L2 = Sheets("Dispositifs").Range("B65536").End(xlUp).Row
Set Plage2 = Sheets("Dispositifs").Range("F9:F" & L2)
For Each Cell In Plage2
If Cell.Value = ReCherche Then
LRecherche = Cell.Row
Cell.Select
End If
Next Cell
Selection.Offset(0, 6).Value = "N"
Sheets("PPSMJ").Activate
Application.ScreenUpdating = True
APPSMJ.CommandButton3.Enabled = True
APPSMJ.CommandButton3.SetFocus

End Sub
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

  • Question Question
Microsoft 365 worksheet_change
Réponses
29
Affichages
540
Réponses
2
Affichages
472
Réponses
10
Affichages
833
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…