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

Regrouper plusieurs Sub en VBA

N

naitgo

XLDnaute Nouveau
Bonjour à tous,

Très moyen en VBA, je bloc sur un petit souci.
Je me retrouve avec 2 x 2 Sub du même nom et je n'arrive pas à les regrouper.
Quelqu'un peut-il m'aider à résoudre ce problème.
D'avance, je vous remercie pour votre aide.

voici le code

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

If Not Application.Intersect(Target, Range("G30")) Is Nothing Then
If Range("G30") = "Exaprint" Then
Rows("50:160").EntireRow.Hidden = True
Rows("33:49").EntireRow.Hidden = False
Else
Rows("50:160").EntireRow.Hidden = False
Rows("33:49").EntireRow.Hidden = True

End If
End If

End Sub



Private Sub Worksheet_SelectionChange(ByVal Target As Range)

 If Range("j14") <> 0 Then
 If Range("k11") = 0 Then
  Range("k11").Interior.ColorIndex = 3
  MsgBox ("Veuillez saisir le format du document ouvert"), vbCritical, "ATTENTION"
  
 Else
 
 If Range("j14") <> 0 Then
 If Range("L11") = 0 Then
 Range("L11").Interior.ColorIndex = 3
  MsgBox ("Veuillez saisir le format du document ouvert"), vbCritical, "ATTENTION"
  
Else

  If Range("k11") >= 0 Then
 Range("k11").Interior.ColorIndex = 2
  If Range("L11") >= 0 Then
 Range("L11").Interior.ColorIndex = 2
  
Cancel = True


End If
End If
End If
End If
End If
End If

End Sub


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim olApp As Outlook.Application
    Dim Cible As Outlook.ContactItem
    Dim dossierContacts As Outlook.MAPIFolder
    Dim Resultat As String
 
    If Not Target.Address = "$D$3" Then Exit Sub
 
    Set olApp = New Outlook.Application
    Set dossierContacts = _
        olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
 
    For Each Cible In dossierContacts.Items
        Resultat = Resultat & Cible.LastName & ","
    Next
 
    Range("D3").Validation.Delete
    Range("D3").Validation.Add xlValidateList, _
                Formula1:=Left(Resultat, Len(Resultat) - 1)
    Set Cible = Nothing
    Set dossierContacts = Nothing
    'olApp.Quit
    Set olApp = Nothing
End Sub



Private Sub Worksheet_Change(ByVal Target As Range)

    Dim olApp As Outlook.Application
    Dim Cible As Outlook.ContactItem
    Dim dossierContacts As Outlook.MAPIFolder
    Dim Recherche As String
 
    If Not Target.Address = "$D$3" Then Exit Sub
 
    On Error GoTo Fin
    Application.EnableEvents = False
 
    Recherche = Range("D3")
 
    Set olApp = New Outlook.Application
    Set dossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
 
    Set Cible = dossierContacts.Items.Find("[LastName] = '" & Recherche & "'")
    If Not Cible Is Nothing Then
        Range("G1") = Cible.CompanyName
        Range("G2") = Cible.FullName
        Range("G3") = Cible.BusinessAddressStreet
        Range("G4") = Cible.BusinessAddressPostalCode
        Range("H4") = Cible.BusinessAddressCity
    End If
 
 
Fin:
Application.EnableEvents = True
    Set Cible = Nothing
    Set dossierContacts = Nothing
    'olApp.Quit
    Set olApp = Nothing
End Sub
 
Trier par date Trier par votes

Vinc

XLDnaute Junior
Re : Regrouper plusieurs Sub en VBA

Bonjour, essai ceci :

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

If Not Application.Intersect(Target, Range("G30")) Is Nothing Then
If Range("G30") = "Exaprint" Then
Rows("50:160").EntireRow.Hidden = True
Rows("33:49").EntireRow.Hidden = False
Else
Rows("50:160").EntireRow.Hidden = False
Rows("33:49").EntireRow.Hidden = True

End If
End If

Dim olApp As Outlook.Application
    Dim Cible As Outlook.ContactItem
    Dim dossierContacts As Outlook.MAPIFolder
    Dim Recherche As String
 
    If Not Target.Address = "$D$3" Then Exit Sub
 
    On Error GoTo Fin
    Application.EnableEvents = False
 
    Recherche = Range("D3")
 
    Set olApp = New Outlook.Application
    Set dossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
 
    Set Cible = dossierContacts.Items.Find("[LastName] = '" & Recherche & "'")
    If Not Cible Is Nothing Then
        Range("G1") = Cible.CompanyName
        Range("G2") = Cible.FullName
        Range("G3") = Cible.BusinessAddressStreet
        Range("G4") = Cible.BusinessAddressPostalCode
        Range("H4") = Cible.BusinessAddressCity
    End If
 
 
Fin:
Application.EnableEvents = True
    Set Cible = Nothing
    Set dossierContacts = Nothing
    'olApp.Quit
    Set olApp = Nothing

End Sub



Private Sub Worksheet_SelectionChange(ByVal Target As Range)

 If Range("j14") <> 0 Then
 If Range("k11") = 0 Then
  Range("k11").Interior.ColorIndex = 3
  MsgBox ("Veuillez saisir le format du document ouvert"), vbCritical, "ATTENTION"
  
 Else
 
 If Range("j14") <> 0 Then
 If Range("L11") = 0 Then
 Range("L11").Interior.ColorIndex = 3
  MsgBox ("Veuillez saisir le format du document ouvert"), vbCritical, "ATTENTION"
  
Else

  If Range("k11") >= 0 Then
 Range("k11").Interior.ColorIndex = 2
  If Range("L11") >= 0 Then
 Range("L11").Interior.ColorIndex = 2
  
Cancel = True


End If
End If
End If
End If
End If
End If

    Dim olApp As Outlook.Application
    Dim Cible As Outlook.ContactItem
    Dim dossierContacts As Outlook.MAPIFolder
    Dim Resultat As String
 
    If Not Target.Address = "$D$3" Then Exit Sub
 
    Set olApp = New Outlook.Application
    Set dossierContacts = _
        olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
 
    For Each Cible In dossierContacts.Items
        Resultat = Resultat & Cible.LastName & ","
    Next
 
    Range("D3").Validation.Delete
    Range("D3").Validation.Add xlValidateList, _
                Formula1:=Left(Resultat, Len(Resultat) - 1)
    Set Cible = Nothing
    Set dossierContacts = Nothing
    'olApp.Quit
    Set olApp = Nothing

End Sub


'Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'End Sub

'Private Sub Worksheet_Change(ByVal Target As Range)
'End Sub
 
Vote positif 0 Vote négatif
N

naitgo

XLDnaute Nouveau
Re : Regrouper plusieurs Sub en VBA

Bonjour Vinc,

Tout d'abord merci d'avoir bien voulu te pencher sur mon problème.

Mais j'ai toujours un message d'erreur au niveau de :
Dim olApp As Outlook.Application
le message d'erreur : Type défini par l'utilisateur non défini
 
Vote positif 0 Vote négatif
N

naitgo

XLDnaute Nouveau
Re : Regrouper plusieurs Sub en VBA

Les codes fonctionnent lorsqu'ils sont seuls
Voici comment ils se présentent à l'origine :
Code 1
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

If Not Application.Intersect(Target, Range("G30")) Is Nothing Then
If Range("G30") = "Exaprint" Then
Rows("50:160").EntireRow.Hidden = True
Rows("33:49").EntireRow.Hidden = False
Else
Rows("50:160").EntireRow.Hidden = False
Rows("33:49").EntireRow.Hidden = True

End If
End If

End Sub



Private Sub Worksheet_SelectionChange(ByVal Target As Range)

 If Range("j14") <> 0 Then
 If Range("k11") = 0 Then
  Range("k11").Interior.ColorIndex = 3
  MsgBox ("Veuillez saisir le format du document ouvert"), vbCritical, "ATTENTION"
  
 Else
 
 If Range("j14") <> 0 Then
 If Range("L11") = 0 Then
 Range("L11").Interior.ColorIndex = 3
  MsgBox ("Veuillez saisir le format du document ouvert"), vbCritical, "ATTENTION"
  
Else

  If Range("k11") >= 0 Then
 Range("k11").Interior.ColorIndex = 2
  If Range("L11") >= 0 Then
 Range("L11").Interior.ColorIndex = 2
  
Cancel = True


End If
End If
End If
End If
End If
End If

End Sub

Code 2
Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim olApp As Outlook.Application
    Dim Cible As Outlook.ContactItem
    Dim dossierContacts As Outlook.MAPIFolder
    Dim Resultat As String
 
    If Not Target.Address = "$A$1" Then Exit Sub
 
    Set olApp = New Outlook.Application
    Set dossierContacts = _
        olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
 
    For Each Cible In dossierContacts.Items
        Resultat = Resultat & Cible.LastName & ","
    Next
 
    Range("A1").Validation.Delete
    Range("A1").Validation.Add xlValidateList, _
                Formula1:=Left(Resultat, Len(Resultat) - 1)
    Set Cible = Nothing
    Set dossierContacts = Nothing
    'olApp.Quit
    Set olApp = Nothing
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
    Dim olApp As Outlook.Application
    Dim Cible As Outlook.ContactItem
    Dim dossierContacts As Outlook.MAPIFolder
    Dim Recherche As String
 
    If Not Target.Address = "$A$1" Then Exit Sub
 
    On Error GoTo Fin
    Application.EnableEvents = False
 
    Recherche = Range("A1")
 
    Set olApp = New Outlook.Application
    Set dossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
 
    Set Cible = dossierContacts.Items.Find("[LastName] = '" & Recherche & "'")
    If Not Cible Is Nothing Then
        Range("A3") = Cible.CompanyName
        Range("A2") = Cible.FullName
        Range("A4") = Cible.BusinessAddressStreet
        Range("A5") = Cible.BusinessAddressPostalCode
        Range("B5") = Cible.BusinessAddressCity
    End If
 
 
Fin:
Application.EnableEvents = True
    Set Cible = Nothing
    Set dossierContacts = Nothing
    'olApp.Quit
    Set olApp = Nothing
End Sub
 
Vote positif 0 Vote négatif
N

naitgo

XLDnaute Nouveau
Re : Regrouper plusieurs Sub en VBA

Après quelques manipulations les deux codes fonctionnent.
Merci quand même Vinc.
Voici les deux codes regroupés :
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Application.Intersect(Target, Range("G30")) Is Nothing Then
If Range("G30") = "Exaprint" Then
Rows("50:160").EntireRow.Hidden = True
Rows("33:49").EntireRow.Hidden = False
Else
Rows("50:160").EntireRow.Hidden = False
Rows("33:49").EntireRow.Hidden = True

End If
End If

    
    Dim olApp As Outlook.Application
    Dim Cible As Outlook.ContactItem
    Dim dossierContacts As Outlook.MAPIFolder
    Dim Recherche As String
    
    If Not Target.Address = "$D$3" Then Exit Sub
        
        On Error GoTo Fin
    Application.EnableEvents = False
 
    Recherche = Range("D3")
 
    Set olApp = New Outlook.Application
    Set dossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
 
    Set Cible = dossierContacts.Items.Find("[LastName] = '" & Recherche & "'")
    If Not Cible Is Nothing Then
        Range("G1") = Cible.CompanyName
        Range("G2") = Cible.FullName
        Range("G3") = Cible.BusinessAddressStreet
        Range("G4") = Cible.BusinessAddressPostalCode
        Range("H4") = Cible.BusinessAddressCity
    End If
 
 
Fin:
Application.EnableEvents = True
    Set Cible = Nothing
    Set dossierContacts = Nothing
    'olApp.Quit
    Set olApp = Nothing
    
    


End Sub



Private Sub Worksheet_SelectionChange(ByVal Target As Range)

 If Range("j14") <> 0 Then
 If Range("k11") = 0 Then
  Range("k11").Interior.ColorIndex = 3
  MsgBox ("Veuillez saisir le format du document ouvert"), vbCritical, "ATTENTION"
  
 Else
 
 If Range("j14") <> 0 Then
 If Range("L11") = 0 Then
 Range("L11").Interior.ColorIndex = 3
  MsgBox ("Veuillez saisir le format du document ouvert"), vbCritical, "ATTENTION"
  
Else

  If Range("k11") >= 0 Then
 Range("k11").Interior.ColorIndex = 2
  If Range("L11") >= 0 Then
 Range("L11").Interior.ColorIndex = 2
  
Cancel = True


End If
End If
End If
End If
End If
End If



    Dim olApp As Outlook.Application
    Dim Cible As Outlook.ContactItem
    Dim dossierContacts As Outlook.MAPIFolder
    Dim Resultat As String
 
    If Not Target.Address = "$D$3" Then Exit Sub
 
    Set olApp = New Outlook.Application
    Set dossierContacts = _
        olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
 
    For Each Cible In dossierContacts.Items
        Resultat = Resultat & Cible.LastName & ","
    Next
 
    Range("D3").Validation.Delete
    Range("D3").Validation.Add xlValidateList, _
                Formula1:=Left(Resultat, Len(Resultat) - 1)
    Set Cible = Nothing
    Set dossierContacts = Nothing
    'olApp.Quit
    Set olApp = Nothing
    
 End Sub
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

A
  • Question
insertion d'une ligne automatique dans un tableau excel.
Réponses
1
Affichages
221
sylvanu
R
  • Résolu(e)
Microsoft 365 Extraction contenu mail outlook vers excel
2
Réponses
18
Affichages
873
raf26
R
A
  • Résolu(e)
XL 2010 Private Sub Worksheet_Change
Réponses
2
Affichages
187
Atlas85200
A
  • Question
Microsoft 365 Trouver et attribuer une plage de cellule en fonction de la cellule active
Réponses
6
Affichages
354
Jojo973
  • Question
Microsoft 365 Incompatibilité de type
Réponses
1
Affichages
238
Dranreb
T
  • Question
Microsoft 365 alerte si cellule change de valeur
Réponses
14
Affichages
252
thenesol
T
E
  • Résolu(e)
Microsoft 365 Copier Coller selon condition
Réponses
5
Affichages
191
TooFatBoy
S
  • Résolu(e)
Microsoft 365 Ecrasement d'une ligne si déjà existante
Réponses
2
Affichages
107
sebastien176
S
E
  • Résolu(e)
XL 2019 transfer listbox vers une colonne à partir de la 4 ligne
Réponses
2
Affichages
107
escudo
E
  • Question
XL 2021 Créer une requête SQL pour lire plusieurs Ranges?
2
Réponses
26
Affichages
896
dysorthographie
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…