Vous utilisez un navigateur obsolète. Il se peut que ce site ou d'autres sites Web ne s'affichent pas correctement. Vous devez le mettre à jour ou utiliser un navigateur alternatif.
Je suis débutant en VBA.
J'essai d'écrire un code qui je pense est très simple, et je pense même avoir lu des parties de réponse sur le forum mais je ne suis toujours pas arrivé à mes fins
J'ai écris une macro qui me permet de rendre deux champs obligatoires si un cellule est non vide (voir ci-dessous)
Maintenant j'ai besoin de faire exactement la même chose mais appliqué à plusieurs lignes, lignes 2 à 2000.
En vain je n'arrive pas à l'écrire.
Ce que je recherche est simplement que si la cellule BX est non vide alors les champs CX et FX deviennent obligatoire et ceux étendu sur 2000 lignes.
Quelqu'un pourrait m'aider.
En vous remerciant.
Salutations
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If Range("B2") <> "" Then
If Range("C2") = "" Or Range("F2") = "" Then
Cancel = True
MsgBox ("Champ obligatoire")
Depuis la dernière fois avec la même base j'ai fait plusieurs codes.
Mais j'ai un problème sur un.
A la fin d'une macro je viens ouvrir un fichier pour pourvoir insérer une pièce jointe.
Ca marche bien, le problème c'est que ce fichier est protégé.
Et même en rajoutant le mot de passe à l'ouverture il s'ouvre tjs verrouillé.
De plus si je vais ouvrir ce fichier manuellement il n'est pas verrouillé.
Sub Enregister_sur_Base_Données_BT()
ActiveSheet.Unprotect "1221" 'DESACTIVATION protection feuille - Mot de passe = 1221
Dim LastRow As Long
Dim WsDepart As Worksheet
Dim WsDestination As Worksheet
Dim Num_BT As String
'Dim Ce_Classeur As String'
Dim Classeur_BT As String
Dim Plg As Range
Dim R As Range
On Error Resume Next
Set Plg = [T11:T12].SpecialCells(xlCellTypeConstants, 23).EntireRow
If Err Then GoTo 26
Set Plg = Intersect([A:A,H:H,I:I,J:J,K:K,U:U,V:V,W:W,X:X,Y:Y,AC:AC,AF:AF,AG:AG,AI:AI,AO:AO,AS:AS,AT:AT,AY:AY,DS:DS], Plg)
If Err Then GoTo 25
Set Plg = Plg.SpecialCells(xlCellTypeBlanks)
If Err Then GoTo 24
Cancel = True
Application.Goto Plg
MsgBox "Champ obligatoire", vbExclamation, "Sauvegarde"
If Plg = Intersect([A:A,H:H,I:I,J:J,K:K,U:U,V:V,W:W,X:X,Y:Y,AC:AC,AF:AF,AG:AG,AI:AI,AO:AO,AS:AS,AT:AT,AY:AY,DS:DS], Plg) Then GoTo 25
24: Set WsDestination = Sheets("Base_Données_BT")
Set WsDepart = Sheets("SAISIES")
LastRow = WsDestination.Range("H" & Rows.Count).End(xlUp).Row
Sheets("Base_Données_BT").Select
' recherche de le dernière cellule vide de la colonne H'
'Il faut que la colonne H est des données'
Num_BT = Worksheets("Base_Données_BT").Cells(LastRow + 1, 2)
Sheets("SAISIES").Select
'Num_BT de l'onglet QA Matrix 2016 de la dernière cellule non vide + 1 ligne, colonne 2'
Application.ScreenUpdating = False
WsDepart.Range("A12").Copy
WsDestination.Range("A" & LastRow + 1).PasteSpecial xlPasteValues
'ECT'
WsDepart.Range("DW12").Copy
WsDestination.Range("DW" & LastRow + 1).PasteSpecial xlPasteValues
' etc ....
'copie des valeurs des cellules ci-dessous dans la première cellule vide de l'onglet QA Matrix 2016
'(ex: copie de H11 dans la première cellule vide de la colonne H de l'onglet QA Matrix 2016)'
WsDepart.Range("A12:J12").ClearContents
Application.ScreenUpdating = False
WsDepart.Range("T12:U12").ClearContents
Application.ScreenUpdating = False
WsDepart.Range("W12:AC12").ClearContents
Application.ScreenUpdating = False
WsDepart.Range("AF12:AO12").ClearContents
Application.ScreenUpdating = False
WsDepart.Range("AR12:AV12").ClearContents
Application.ScreenUpdating = False
WsDepart.Range("AX12:BI12").ClearContents
Application.ScreenUpdating = False
WsDepart.Range("BU12:DW12").ClearContents
Application.ScreenUpdating = False
'Efface les données de A12:J12 puis T12:U12 ect de l'ongelt "saisie"'
Set WsDestination = Nothing
Set WsDepart = Nothing
'Affiche le numéro de la cellule situé ligne ,col
Sheets("SAISIES").Select
Cells(3, 6) = Num_BT
Num_BT = "K:\GROUPES\PARTAGE\WCM\6. Pilier QC\Recolte BJ Zone2\Pièces jointes-BT à Imprimer\Pièces_jointes\" + Num_BT + ".xls"
'Ouverture d'un fichier simple (déclaration Ce_Classeur + Classeur_BT as string)
'Récupération du nom du fichier en cours
Classeur_BT = ActiveWorkbook.Name
'Ouverture du fichier
Workbooks.Open Filename:=Num_BT, Password:="1221"
ActiveSheet.Protect "1221" 'ACTIVATION protection feuille - Mot de passe = 1221
If Error Then GoTo 25 Else GoTo 25
'Classeur_BT = ActiveWorkbook.Name'
26: MsgBox "Champ verts et rouges obligatoire", vbExclamation, "Sauvegarde"
25: ActiveSheet.Protect "1221" 'ACTIVATION protection feuille - Mot de passe = 1221
End Sub
Bonsoir, en fait le fichier était protégé car j'avais copier un "sous-dossier " contenant ces fichiers qui était en lecteur seul et dans le nouvel emplacement il avait gardé sa protection.
donc résolu.
Parcontre j'aurai une question,
le code: Set Plg = [T11:T12].SpecialCells(xlCellTypeConstants, 23).EntireRow ;dans cette ligne on vient vérifier si il y a des valeurs dans la plage T11 à T12.
Mais si je veux vérifier seulement dans une cellule que devrais-je écrire. j'ai essayé le code : Set Plg = [T12].SpecialCells(xlCellTypeConstants, 23).EntireRow mais ca ne fonctionne pas (elle est accepté en écriture mais lors du déroulement du code ca ne contrôle pas si il y a quelque chose dans la cellule T12. j'ai aussi essayé "notempty" ou "specialcells. value" mais en vain.
Bonsoir.
Ben non, pour contrôler une seule cellule bien déterminée c'est beaucoup plus simple.
Par exemple :
If Not IsEmpty(ActiveSheet.[T12].Value) Then
Merci pour la réponse.
Mais ensuite je ne sais pas comment faire pour la suite du code, car j'ai ensuite une fonction Intersect() qui ne marche pas.
mon code :
On Error Resume Next
Set Plg = [T12].SpecialCells(xlCellTypeConstants, 23).EntireRow
If Err Then GoTo 26
Set Plg = Intersect([A12,H12,I12,J12,K12,U12,V12,W12,X12,Y12,AC12,AF12,AG12,AI12,AO12,AS12,AT12,AY12,DS12], Plg)
If Err Then GoTo 25
Set Plg = Plg.SpecialCells(xlCellTypeBlanks)
If Err Then GoTo 24
Cancel = True
Application.Goto Plg
Au départ vous m'aviez aidé sur cette formule pour des plages et dans "Intersect()" il y avait des colonnes entières, dans cette version j'ai mis des cellules unique car je ne veux controller que les cellules de la lignes 12.
du coup dans le code "Set Plg = [T12].SpecialCells(xlCellTypeConstants, 23).EntireRow" je n'aurai besoin que de T12, mais bon ca ne marche pas.
Je n'en sait rien. Je n'ai aucune idée du résultat que vous voulez atteindre.
Et je ne peux pas écrire et tester quelque chose parce que vous n'avez jamais joint de classeur.
Merci pour votre réponse.
Ce que je souhaiterai faire ce serait comme le code précédent mais avec une seul cellule en conditions au lieu d'une plage "T11:T12", pour le reste exactement la même chose.
Lorsque qu'il n'y a rien dans la cellule T12, que le message Champs vert et rouges obligatoires apparaissent.
Aujourd'hui le code c'est:
"On Error Resume Next
Set Plg = [T11:T12].SpecialCells(xlCellTypeConstants, 23).EntireRow
If Err Then Goto 26" en 26 il y a le message
Ensuite si la conditions de dessus est ok c'est de vérifier que certaines cellules de la ligne 12 sont remplis, si elles ne le sont pas c'est de faire apparaitre le message "Champ obligatoire" et de surligner les cellules vides.
Aujourd'hui le code est:
"Set Plg = Intersect([A12,H12,I12,J12,K12,U12,V12,W12,X12,Y12,AC12,AF12,AG12,AI12,AO12,AS12,AT12,AY12,DS12], Plg)
If Err Then GoTo 24
Set Plg = Plg.SpecialCells(xlCellTypeBlanks)
If Err Then GoTo 24
Cancel = True
Application.Goto Plg
MsgBox "Champ obligatoire", vbExclamation, "Sauvegarde"
If Plg = ActiveSheet.[A12,H12,I12,J12,K12,U12,V12,W12,X12,Y12,AC12,AF12,AG12,AI12,AO12,AS12,AT12,AY12,DS12].SpecialCells(xlCellTypeBlanks) Then GoTo 25
24:
"
24 est l'action suivante ou je demande de faire un copier/coller des données dans un autre onglet, de supprimer ce qui à été saisie dans le premier onglets ect..
J'ai essayé avec le code que vous m'avez donné, voir ci dessous.
mais ca ne marche pas.
Ci-dessous merci de trouver le code, je les un peu raccourci car trop grand. Les codes que vous m'avez donné sont dedans et en commentaire j'ai laissé ce d'avants.
Merci de votre aide.
Code:
Sub Enregister_sur_Base_Données_BT()
Dim LastRow As Long
Dim WsDepart As Worksheet
Dim WsDestination As Worksheet
Dim Num_BT As String
Dim Classeur_BT As String
Dim Plg As Range
Dim R As Range
On Error Resume Next
'Set Plg = [T11:T12].SpecialCells(xlCellTypeConstants, 23).EntireRow
If Not IsEmpty(ActiveSheet.[T12].Value) Then GoTo 28
GoTo 26
28: 'Set Plg = Intersect([A12,H12,I12,J12,K12,U12,V12,W12,X12,Y12,AC12,AF12,AG12,AI12,AO12,AS12,AT12,AY12,DS12], Plg)
Set Plg = ActiveSheet.[A12,H12:K12,U12:Y12,AC12,AF12,AG12,AI12,AO12,AS12,AT12,AY12,DS12].SpecialCells(xlCellTypeBlanks)
If Err Then GoTo 24
'Set Plg = Plg.SpecialCells(xlCellTypeBlanks)
'If Err Then GoTo 24
Cancel = True
Application.Goto Plg
MsgBox "Champ obligatoire", vbExclamation, "Sauvegarde"
If Plg = ActiveSheet.[A12,H12,I12,J12,K12,U12,V12,W12,X12,Y12,AC12,AF12,AG12,AI12,AO12,AS12,AT12,AY12,DS12].SpecialCells(xlCellTypeBlanks) Then GoTo 25
24: Set WsDestination = Sheets("Base_Données_BT")
Set WsDepart = Sheets("SAISIES")
LastRow = WsDestination.Range("H" & Rows.Count).End(xlUp).Row
Sheets("Base_Données_BT").Select
' recherche de le dernière cellule vide de la colonne H'
'Il faut que la colonne H est des données'
Num_BT = Worksheets("Base_Données_BT").Cells(LastRow + 1, 2)
Sheets("SAISIES").Select
'Num_BT de l'onglet QA Matrix 2016 de la dernière cellule non vide + 1 ligne, colonne 2'
Application.ScreenUpdating = False
WsDepart.Range("A12").Copy
WsDestination.Range("A" & LastRow + 1).PasteSpecial xlPasteValues
....etc
WsDestination.Range("DT" & LastRow + 1).PasteSpecial xlPasteValues
WsDepart.Range("DW12").Copy
WsDestination.Range("DW" & LastRow + 1).PasteSpecial xlPasteValues
'copie des valeurs des cellules ci-dessous dans la première cellule vide de l'onglet QA Matrix 2016
'(ex: copie de H11 dans la première cellule vide de la colonne H de l'onglet QA Matrix 2016)'
WsDepart.Range("A12:J12").ClearContents
Application.ScreenUpdating = False
WsDepart.Range("T12:U12").ClearContents
Application.ScreenUpdating = False
WsDepart.Range("W12:AC12").ClearContents
Application.ScreenUpdating = False
WsDepart.Range("AF12:AO12").ClearContents
Application.ScreenUpdating = False
WsDepart.Range("AR12:AV12").ClearContents
Application.ScreenUpdating = False
WsDepart.Range("AX12:BI12").ClearContents
Application.ScreenUpdating = False
WsDepart.Range("BU12:DW12").ClearContents
Application.ScreenUpdating = False
'Efface les données de A12:J12 puis T12:U12 ect de l'ongelt "saisie"'
Set WsDestination = Nothing
Set WsDepart = Nothing
'Affiche le numéro de la cellule situé ligne ,col
Sheets("SAISIES").Select
Cells(3, 6) = Num_BT
Num_BT = "L:\BDONNEES\BT\Recolte BJ Zone2\Pièces jointes-BT à Imprimer\Pièces_jointes\" + Num_BT + ".xls"
'Récupération du nom du fichier en cours
''Ce_Classeur = ActiveWorkbook.Name''
Classeur_BT = ActiveWorkbook.Name
'Ouverture du fichier
Workbooks.Open Filename:=Num_BT, Password:="1221"
If Error Then GoTo 25 Else GoTo 25
26: MsgBox "Champs verts et rouges obligatoires", vbExclamation, "Sauvegarde"
25:
End Sub
Bonjour.
Éviter les GoTo. Préférez les structures If Condition1 Then … ElseIf Condition2 Then … ElseIf ConditionX Then … Else … End If
Je ne peux pas comprendre pourquoi ça ne marche pas. Bouton Téléverser un fichier, si vous voulez que je cherche.
Oui j'ai souvent lu que c'est déconseillé mais comme je ne suis pas un expert j'ai réussi à le faire marcher comme ça.
j'ai mis le fichier comme demandé.
merci beaucoup
Ce site utilise des cookies pour personnaliser le contenu, adapter votre expérience et vous garder connecté si vous vous enregistrez.
En continuant à utiliser ce site, vous consentez à notre utilisation de cookies.
