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

A
  • Question
insertion d'une ligne automatique dans un tableau excel.
Réponses
1
Affichages
221
sylvanu
sylvanu
R
  • Résolu(e)
Microsoft 365 Extraction contenu mail outlook vers excel
2
Réponses
18
Affichages
872
raf26
R
A
  • Résolu(e)
XL 2010 Private Sub Worksheet_Change
Réponses
2
Affichages
187
Atlas85200
A
Jojo973
  • Question
Microsoft 365 Trouver et attribuer une plage de cellule en fonction de la cellule active
Réponses
6
Affichages
354
Jojo973
Jojo973
PORCHER
  • Question
Microsoft 365 Incompatibilité de type
Réponses
1
Affichages
238
Dranreb
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
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
p'tit vieux
  • Question
XL 2021 Créer une requête SQL pour lire plusieurs Ranges?
2
Réponses
26
Affichages
896
dysorthographie
dysorthographie

Membres actuellement en ligne

5 membres et 64 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
314 628
Messages
2 111 337
Membres
111 107
dernier inscrit
cdel