FONCTION VBA beaucoup trop grande....

A

alain.raphael

XLDnaute Occasionnel
Bonjour à Tous,

J'ai une Fonction SUB > à 64 Ko, et je ne sais pas comment la réduire.

J'ai des champs dans un formulaire (Date, numéro....) et des CheckBox concernant 24 personnes.

Si je sélectionne les CheckBox 1 et 3, les données des champs se remplissent après validation du formulaire dans les pages des personnes 1 et 3, mais aussi le nom des autres personnes des checkBox cochées :

Exemple : CheckBox 1, 3, 4 cochées : sur la page 1 le nom des personnes 3 et 4 s'affichent (ainsi que les données)
sur la page 3 le nom des personnes 1 et 4 s'affichent
sur la page 4 le nom des personnes 1 et 3 s'affichent.

Ci-joint le code :
Code: 
Private Sub VALIDERINDIVIDU_Click()
'declaration des variables
Dim DatePlongee As String * 10
Dim LieuPlongee As String * 60
Dim CommunePlonge As String * 30
Dim EICSTPlongee As String
Dim ButPlongee As String * 100
Dim HeureDebutimmersionPlongee As String
Dim HeureFinimmersionPlongee As String
Dim DureePLongee As String * 3
Dim ProfondeurPlongee As String * 2
Dim CourantPlongee As String
Dim Ecriture As Boolean
Dim VisibilitePlongee As String
Dim TemperaturePlongee As String
Dim NomDPPlongee As String
Dim NumLigne, NbPlongees As Integer
Dim Cellule As String

'Affectations des variables

DatePlongee = Da.Text
LieuPlongee = Lieu.Text
CommunePlongee = Com.Text
EICSTPlongee = ComboBoxEICST.Value
ButPlongee = But.Text
HeureDebutimmersionPlongee = Hd.Value
HeureFinimmersionPlongee = Hf.Value
DureePLongee = Duree.Text
ProfondeurPlongee = Pro.Text
CourantPlongee = ComboBoxCou.Value
VisibilitePlongee = ComboBoxVisi.Value
TemperaturePlongee = T.Text
NomDPPlongee = ComboBoxDP.Value


Range("A7").Select


'Avertissement que les champs soient remplis
If DatePlongee = "" Or LieuPlongee = "" Or CommunePlongee = "" Or EICSTPlongee = "" Or ButPlongee = "" Or HeureDebutimmersionPlongee = "" Or HeureFinimmersionPlongee = "" Or DureePLongee = "" Or ProfondeurPlongee = "" Or CourantPlongee = "" Or VisibilitePlongee = "" Or TemperaturePlongee = "" Or NomDPPlongee = "" Then
Reponse = MsgBox("Vous avez oublié de remplir certains champs !!", 0, "Informations manquantes")

Else


'insertion des valeurs sur les feuilles individuelles

If CheckBox1.Value Then

NumLigne = Feuil4.Range("a65536").End(xlUp).Row + 1
Feuil4.Cells(NumLigne, 1) = NumLigne - 6
Feuil4.Cells(NumLigne, 2) = CDate(Da.Value)
Feuil4.Cells(NumLigne, 3) = Lieu.Value
Feuil4.Cells(NumLigne, 4) = Com.Value
Feuil4.Cells(NumLigne, 5) = ComboBoxEICST.Value
Feuil4.Cells(NumLigne, 6) = But.Value
Feuil4.Cells(NumLigne, 7) = Hd.Value
Feuil4.Cells(NumLigne, 8) = Hf.Value
Feuil4.Cells(NumLigne, 9) = Duree.Value
Feuil4.Cells(NumLigne, 10) = Pro.Value
Feuil4.Cells(NumLigne, 11) = ComboBoxCou.Value
Feuil4.Cells(NumLigne, 12) = ComboBoxVisi.Value
Feuil4.Cells(NumLigne, 13) = T.Value
Feuil4.Cells(NumLigne, 14) = ComboBoxDP.Value
  If CheckBox2.Value Then
 Feuil4.Cells(NumLigne, 17) = "2"
 Else
 Feuil4.Cells(NumLigne, 17) = ""
 End If
  If CheckBox3.Value Then
 Feuil4.Cells(NumLigne, 18) = "3"
 Else
 Feuil4.Cells(NumLigne, 18) = ""
 End If
  If CheckBox4.Value Then
 Feuil4.Cells(NumLigne, 19) = "4"
 Else
 Feuil4.Cells(NumLigne, 19) = ""
 End If
  If CheckBox5.Value Then
 Feuil4.Cells(NumLigne, 20) = "5"
 Else
 Feuil4.Cells(NumLigne, 20) = ""
 End If
  If CheckBox6.Value Then
 Feuil4.Cells(NumLigne, 21) = "6"
 Else
 Feuil4.Cells(NumLigne, 21) = ""
 End If
  If CheckBox7.Value Then
 Feuil4.Cells(NumLigne, 22) = "7"
 Else
 Feuil4.Cells(NumLigne, 22) = ""
 End If
  If CheckBox8.Value Then
 Feuil4.Cells(NumLigne, 23) = "8"
 Else
 Feuil4.Cells(NumLigne, 23) = ""
 End If
  If CheckBox9.Value Then
 Feuil4.Cells(NumLigne, 24) = "9"
 Else
 Feuil4.Cells(NumLigne, 24) = ""
 End If
  If CheckBox10.Value Then
 Feuil4.Cells(NumLigne, 25) = "10"
 Else
 Feuil4.Cells(NumLigne, 25) = ""
 End If
  If CheckBox11.Value Then
 Feuil4.Cells(NumLigne, 26) = "11"
 Else
 Feuil4.Cells(NumLigne, 26) = ""
 End If
  If CheckBox12.Value Then
 Feuil4.Cells(NumLigne, 27) = "12"
 Else
 Feuil4.Cells(NumLigne, 27) = ""
 End If
  If CheckBox13.Value Then
 Feuil4.Cells(NumLigne, 28) = "13"
 Else
 Feuil4.Cells(NumLigne, 28) = ""
 End If
  If CheckBox14.Value Then
 Feuil4.Cells(NumLigne, 29) = "14"
 Else
 Feuil4.Cells(NumLigne, 29) = ""
 End If
  If CheckBox15.Value Then
 Feuil4.Cells(NumLigne, 30) = "15"
 Else
 Feuil4.Cells(NumLigne, 30) = ""
 End If
  If CheckBox16.Value Then
 Feuil4.Cells(NumLigne, 31) = "16"
 Else
 Feuil4.Cells(NumLigne, 31) = ""
 End If
  If CheckBox17.Value Then
 Feuil4.Cells(NumLigne, 33) = "17"
 Else
 Feuil4.Cells(NumLigne, 33) = ""
 End If
  If CheckBox18.Value Then
 Feuil4.Cells(NumLigne, 34) = "18"
 Else
 Feuil4.Cells(NumLigne, 34) = ""
 End If
  If CheckBox19.Value Then
 Feuil4.Cells(NumLigne, 35) = "19"
 Else
 Feuil4.Cells(NumLigne, 35) = ""
 End If
 If CheckBox20.Value Then
 Feuil4.Cells(NumLigne, 36) = "20"
 Else
 Feuil4.Cells(NumLigne, 36) = ""
 End If
  If CheckBox21.Value Then
 Feuil4.Cells(NumLigne, 37) = "21"
 Else
 Feuil4.Cells(NumLigne, 37) = ""
 End If
  If CheckBox22.Value Then
 Feuil4.Cells(NumLigne, 38) = "22"
 Else
 Feuil4.Cells(NumLigne, 38) = ""
 End If
  If CheckBox23.Value Then
 Feuil4.Cells(NumLigne, 39) = "23"
 Else
 Feuil4.Cells(NumLigne, 39) = ""
 End If
  If CheckBox24.Value Then
 Feuil4.Cells(NumLigne, 40) = "24"
 Else
 Feuil4.Cells(NumLigne, 40) = ""
 End If

End If

  'insertion des valeurs sur les feuilles individuelles

If CheckBox2.Value Then

NumLigne = Feuil5.Range("a65536").End(xlUp).Row + 1
Feuil5.Cells(NumLigne, 1) = NumLigne - 6
Feuil5.Cells(NumLigne, 2) = CDate(Da.Value)
Feuil5.Cells(NumLigne, 3) = Lieu.Value
Feuil5.Cells(NumLigne, 4) = Com.Value
Feuil5.Cells(NumLigne, 5) = ComboBoxEICST.Value
Feuil5.Cells(NumLigne, 6) = But.Value
Feuil5.Cells(NumLigne, 7) = Hd.Value
Feuil5.Cells(NumLigne, 8) = Hf.Value
Feuil5.Cells(NumLigne, 9) = Duree.Value
Feuil5.Cells(NumLigne, 10) = Pro.Value
Feuil5.Cells(NumLigne, 11) = ComboBoxCou.Value
Feuil5.Cells(NumLigne, 12) = ComboBoxVisi.Value
Feuil5.Cells(NumLigne, 13) = T.Value
Feuil5.Cells(NumLigne, 14) = ComboBoxDP.Value
  If CheckBox1.Value Then
 Feuil5.Cells(NumLigne, 16) = "1"
 Else
 Feuil5.Cells(NumLigne, 16) = ""
 End If
  If CheckBox3.Value Then
 Feuil5.Cells(NumLigne, 18) = "3"
 Else
 Feuil5.Cells(NumLigne, 18) = ""
 End If

                                                                 Etc…….

End If

                                                  ETC…POUR LES 22 autres CHECKBOX…….

'fin
If MsgBox("Une fois affectée, Pensez à VALIDER la Plongée", vbOKOnly, "2ème bouton") = vbOK Then

Range("A1").Select

End If
End If
End Sub
 
Trier par date Trier par votes
Paf

Paf

XLDnaute Barbatruc
Re : FONCTION VBA beaucoup trop grande....

Bonjour à tous

Pour simplifier la partie If CheckBox2.Value Then à If CheckBox24.Value Then, on pourrait utiliser deux boucles puis qu'il n'y a rien en colonne 32:
Code: 
For i= 2 to 16
   Feuil4.Cells(NumLigne, i + 15) = Me.Controls("CheckBox" & i).Value  * i
Next

et
Code: 
For i= 17 to 24
   Feuil4.Cells(NumLigne, i + 16) = Me.Controls("CheckBox" & i).Value  * i
Next

Pas testé faute de jeux d'essais

A+

Edit: Pas sûr que Me.Controls("CheckBox" & i).Value * i le fasse, peut être Val(Me.Controls("CheckBox" & i).Value) * i
 
Dernière édition:
Vote positif 0 Vote négatif
Paf

Paf

XLDnaute Barbatruc
Re : FONCTION VBA beaucoup trop grande....

re

de visu pour chaque checkbox c'est bien Feuil4 qui est utilisée !

Comme le précise Efgé, il faut le classeur pour déceler éventuellement d'autres optimisations de codes,

Bonne suite
Code: 
If CheckBox2.Value Then
 Feuil4.Cells(NumLigne, 17) = "2"
 Else
 Feuil4.Cells(NumLigne, 17) = ""
 End If
  If CheckBox3.Value Then
 Feuil4.Cells(NumLigne, 18) = "3"
 Else
 Feuil4.Cells(NumLigne, 18) = ""
 End If
  If CheckBox4.Value Then
 Feuil4.Cells(NumLigne, 19) = "4"
 Else
 Feuil4.Cells(NumLigne, 19) = ""
 End If
  If CheckBox5.Value Then
 Feuil4.Cells(NumLigne, 20) = "5"
 Else
 Feuil4.Cells(NumLigne, 20) = ""
 End If
  If CheckBox6.Value Then
 Feuil4.Cells(NumLigne, 21) = "6"
 Else
 Feuil4.Cells(NumLigne, 21) = ""
 End If
  If CheckBox7.Value Then
 Feuil4.Cells(NumLigne, 22) = "7"
 Else
 Feuil4.Cells(NumLigne, 22) = ""
 End If
  If CheckBox8.Value Then
 Feuil4.Cells(NumLigne, 23) = "8"
 Else
 Feuil4.Cells(NumLigne, 23) = ""
 End If
  If CheckBox9.Value Then
 Feuil4.Cells(NumLigne, 24) = "9"
 Else
 Feuil4.Cells(NumLigne, 24) = ""
 End If
  If CheckBox10.Value Then
 Feuil4.Cells(NumLigne, 25) = "10"
 Else
 Feuil4.Cells(NumLigne, 25) = ""
 End If
  If CheckBox11.Value Then
 Feuil4.Cells(NumLigne, 26) = "11"
 Else
 Feuil4.Cells(NumLigne, 26) = ""
 End If
  If CheckBox12.Value Then
 Feuil4.Cells(NumLigne, 27) = "12"
 Else
 Feuil4.Cells(NumLigne, 27) = ""
 End If
  If CheckBox13.Value Then
 Feuil4.Cells(NumLigne, 28) = "13"
 Else
 Feuil4.Cells(NumLigne, 28) = ""
 End If
  If CheckBox14.Value Then
 Feuil4.Cells(NumLigne, 29) = "14"
 Else
 Feuil4.Cells(NumLigne, 29) = ""
 End If
  If CheckBox15.Value Then
 Feuil4.Cells(NumLigne, 30) = "15"
 Else
 Feuil4.Cells(NumLigne, 30) = ""
 End If
  If CheckBox16.Value Then
 Feuil4.Cells(NumLigne, 31) = "16"
 Else
 Feuil4.Cells(NumLigne, 31) = ""
 End If
  If CheckBox17.Value Then
 Feuil4.Cells(NumLigne, 33) = "17"
 Else
 Feuil4.Cells(NumLigne, 33) = ""
 End If
  If CheckBox18.Value Then
 Feuil4.Cells(NumLigne, 34) = "18"
 Else
 Feuil4.Cells(NumLigne, 34) = ""
 End If
  If CheckBox19.Value Then
 Feuil4.Cells(NumLigne, 35) = "19"
 Else
 Feuil4.Cells(NumLigne, 35) = ""
 End If
 If CheckBox20.Value Then
 Feuil4.Cells(NumLigne, 36) = "20"
 Else
 Feuil4.Cells(NumLigne, 36) = ""
 End If
  If CheckBox21.Value Then
 Feuil4.Cells(NumLigne, 37) = "21"
 Else
 Feuil4.Cells(NumLigne, 37) = ""
 End If
  If CheckBox22.Value Then
 Feuil4.Cells(NumLigne, 38) = "22"
 Else
 Feuil4.Cells(NumLigne, 38) = ""
 End If
  If CheckBox23.Value Then
 Feuil4.Cells(NumLigne, 39) = "23"
 Else
 Feuil4.Cells(NumLigne, 39) = ""
 End If
  If CheckBox24.Value Then
 Feuil4.Cells(NumLigne, 40) = "24"
 Else
 Feuil4.Cells(NumLigne, 40) = ""
 End If
 
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Re : FONCTION VBA beaucoup trop grande....

Bonjour.
Vous gagneriez en rapidité en rangeant préalablement les valeurs dans un tableau de Variant d'une ligne et 40 colonne, et en le déchargeant d'un coup :
VB: 
Feuil5.Cells(NumLigne, 1).Resize(, 40).Value2 = Ts
Ce qui n'empêcherai de le combiner avec une ligne du genre:
VB: 
For C = 2 To 24: Ts(1, C + 15) = IIf(Me("CheckBox" & C).Value, C, Empty): Next C
 
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : FONCTION VBA beaucoup trop grande....

Re alain.raphael
Bonjour Paf, Dranreb

Ma seule proposition, jetée sans test aucun:
J'étais parti également sur un tableau:
Une fonction
VB: 
Private Function Rouler(Sh As Worksheet, A As Long)
Dim i&, NumLigne&, TData(1 To 1, 1 To 40) As Variant
NumLigne = Sh.Cells(Sh.Rows.Count, 1).End(xlUp).Row + 1
TData(1, 1) = NumLigne - 6
TData(1, 2) = CDate(Da.Value)
TData(1, 3) = Lieu.Value
TData(1, 4) = Com.Value
TData(1, 5) = ComboBoxEICST.Value
TData(1, 6) = But.Value
TData(1, 7) = Hd.Value
TData(1, 8) = Hf.Value
TData(1, 9) = Duree.Value
TData(1, 10) = Pro.Value
TData(1, 11) = ComboBoxCou.Value
TData(1, 12) = ComboBoxVisi.Value
TData(1, 13) = T.Value
TData(1, 14) = ComboBoxDP.Value
For i = 1 To 24
    If i  A Then
        TData(1, i + 15 + (i > 15)) = i
    End If
Next i
Sh.Cells(NumliLigne, 1).Resize(, 40) = TData
End Function

Et pour l'appeler
VB: 
Sub test()
Dim F As Worksheet, X&
If CheckBox1.Value Then
    X = 1
    Set F = Sheets("Feuil4")
    Rouler F, X
End If
End Sub

Cordialement
 
Vote positif 0 Vote négatif
A

alain.raphael

XLDnaute Occasionnel
Re : FONCTION VBA beaucoup trop grande....

Je voulais aller dans ce sens : il y a des champs textes et 24 CheckBox concernant 24 personnes (et donc 24 feuillets).
Si je selectionne une checkbox, cela incrémente le feuillet de la personne des champs textes ET les noms des autres personnes/checkbox sélectionnés....

Code: 
'Boucles

For i = 1 To 24
    If i = 1 Then
       Sheets("feuil1").Select
    End If
       
    If i = 2 Then
       Sheets("feuil2").Select
    End If
    
    If i = 3 Then
       Sheets("feuil3").Select
    End If
    
    If i = 4 Then
       Sheets("feuil4").Select
    End If
    
    If i = 5 Then
       Sheets("feuil5").Select
    End If
    
    If i = 6 Then
       Sheets("feuil6").Select
    End If
    
    If i = 7 Then
       Sheets("feuil7").Select
    End If
    
    If i = 8 Then
       Sheets("feuil8").Select
    End If
    
    If i = 9 Then
       Sheets("feuil9").Select
    End If
    
    If i = 10 Then
       Sheets("feuil10").Select
    End If
    
    If i = 11 Then
       Sheets("feuil11").Select
    End If
    
    If i = 12 Then
       Sheets("feuil12").Select
    End If
    
    If i = 13 Then
       Sheets("feuil13").Select
    End If
    
    If i = 14 Then
       Sheets("feuil14").Select
    End If
    
    If i = 15 Then
       Sheets("feuil15").Select
    End If
    
    If i = 16 Then
       Sheets("feuil16").Select
    End If
    
    If i = 17 Then
       Sheets("feuil17").Select
    End If
    
    If i = 18 Then
       Sheets("feuil18").Select
    End If
    
    If i = 19 Then
       Sheets("feuil19").Select
    End If
    
    If i = 20 Then
       Sheets("feuil20").Select
    End If
    
    If i = 21 Then
       Sheets("feuil21").Select
    End If
    
    If i = 22 Then
       Sheets("feuil22").Select
    End If
    
    If i = 23 Then
       Sheets("feuil23").Select
    End If
    
    If i = 24 Then
       Sheets("feuil24").Select
    End If
    
 Next
    
NumLigne = Range("a65536").End(xlUp).Row + 1

'insertion des valeurs sur les feuilles individuelles

Cells(NumLigne, 1) = NumLigne - 6
Cells(NumLigne, 2) = CDate(Da.Value)
Cells(NumLigne, 3) = Lieu.Value
Cells(NumLigne, 4) = Com.Value
Cells(NumLigne, 5) = ComboBoxEICST.Value
Cells(NumLigne, 6) = But.Value
Cells(NumLigne, 7) = Hd.Value
Cells(NumLigne, 8) = Hf.Value
Cells(NumLigne, 9) = Duree.Value
Cells(NumLigne, 10) = Pro.Value
Cells(NumLigne, 11) = ComboBoxCou.Value
Cells(NumLigne, 12) = ComboBoxVisi.Value
Cells(NumLigne, 13) = T.Value
Cells(NumLigne, 14) = ComboBoxDP.Value
  If CheckBoxPersonne1.Value Then
 Cells(NumLigne, 17) = "Personne1"
 Else
 Cells(NumLigne, 17) = ""
 End If
  If CheckBoxPersonne2.Value Then
 Cells(NumLigne, 18) = "Personne2"
 Else
 Cells(NumLigne, 18) = ""
 End If
  If CheckBoxPersonne3.Value Then
 Cells(NumLigne, 19) = "Personne3"
 Else
 Cells(NumLigne, 19) = ""
 End If
 
etc....

End If
 
Dernière édition:
Vote positif 0 Vote négatif
Paf

Paf

XLDnaute Barbatruc
Re : FONCTION VBA beaucoup trop grande....

Re,

par MP vous précisez ne pas pouvoir dépersonnaliser votre classeur pour le mettre en ligne (?)
modifier les noms ne suffirait-il pas ?

Je ne comprend pas ce que vous tentez de faire entre les feuilles et les checkbox.

Sans structures du classeur, du userform et sans savoir ce que vous tentez de faire, je crois que nous allons tourner en rond .

A+

Edit : j'ai lu un peu vite le post #1, il y a des explications ! :confused:
 
Dernière édition:
Vote positif 0 Vote négatif
Paf

Paf

XLDnaute Barbatruc
Re : FONCTION VBA beaucoup trop grande....

en attendant voila ce que j'ai compris

pour chaque checkbox coché, on écrit dans la feuille correspondant le nom des autres checkbox cochés.



Code: 
For i = 1 To 24
    If Controls("CheckBox" & i) = True Then
        For j = 1 To 24
            If j <> i And Controls("CheckBox" & j) = True Then
                With Worksheets("Feuil" & i)
                    NumLigne = .Range("a65536").End(xlUp).Row + 1
                    .Cells(NumLigne, j) = Controls("CheckBox" & j).Caption
                End With
            End If
        Next
    End If
Next

A+
 
Vote positif 0 Vote négatif

Discussions similaires

E
  • Résolu(e)
Microsoft 365 Boucle sur lignes <>0
Réponses
2
Affichages
156
eric72
E
D
  • Question
XL 2010 Valoriser cellule par clic
Réponses
4
Affichages
233
fanch55
fanch55
D
  • Question
XL 2010 Identification d'une cellule cliquée
Réponses
6
Affichages
353
dadu35
D
yojema
  • Question
XL 2021 faire évoluer un code VBA
Réponses
3
Affichages
170
Dranreb
Dranreb
S
  • Question
XL 2021 macro VBA excel
Réponses
1
Affichages
177
crocrocro
C
L
  • Question
VBA : erreur sur boucle
Réponses
2
Affichages
84
Latias
L
M
  • Question
Microsoft 365 Modifier code et format textbox
2 3
Réponses
35
Affichages
738
Marvin57
M
S
  • Question
Microsoft 365 créer un macro vba
Réponses
0
Affichages
157
souhaib ad
S
petitbuzuc
  • Question
XL 2016 Aide pour maj auto de la date + selection multiple dans une liste déroulante
Réponses
5
Affichages
240
fanch55
fanch55
A
  • Question
Microsoft 365 Code VBA Envoi contenu tableau Excel par Email
Réponses
1
Affichages
124
Phil69970
Phil69970

Membres actuellement en ligne

13 membres et 136 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 331
Messages
2 087 353
Membres
103 528
dernier inscrit
hplus