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

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

Discussions similaires

chaelie2015
  • Résolu(e)
XL 2013 (RESOLU) Efface automatiquement le contenu d'une cellule en fonction d'une autre cellule
Réponses
9
Affichages
327
chaelie2015
chaelie2015
P
  • Question
Outlook Outlook imprimer mail et PJ en PDF
Réponses
2
Affichages
546
paulng
P
H
  • Résolu(e)
sub en function
Réponses
2
Affichages
264
Hunter296
H
T
  • Résolu(e)
XL 2010 VBA - Fonction double clics à opérations multiples
Réponses
2
Affichages
181
Titi456
T
U
  • Question
Autres Comment puis-je m'en sortir?
Réponses
2
Affichages
262
un internaute
U
K
  • Résolu(e)
XL 2019 Probleme codage
Réponses
2
Affichages
252
Kevin42560
K
N
  • Résolu(e)
XL 2021 Masquer ligne vba
Réponses
2
Affichages
313
NicolasKH
N
F
  • Question
XL 2019 erreur 1004
Réponses
8
Affichages
259
florian50470
F
F
  • Question
XL 2016 Ajouter planning Outlook un rdv(sans activer de reference "Microsoft Outlook object library xx.x"
Réponses
2
Affichages
276
fredl
F
gothc
  • Question
XL 2021 choisir un onglet avant envoyer par email
Réponses
2
Affichages
356
gothc
gothc

Membres actuellement en ligne

14 membres et 169 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 387
Messages
2 087 858
Membres
103 671
dernier inscrit
rachid1983