double condition ne fonctionne pas

superbog · 21 Septembre 2012

Bonjour à tous,

voilà, j'ai une macro qui fonctionne parfaitement mais quand je veux lui ajouter une double condition, elle ne prend pas en compte cette demande.

Il s'agit à partir d'une feuille contenant une liste de clients, de créer un onglet par client mais seulement si l'onglet n'existe pas déjà ET si la colonne O de la ligne considérée est vide

or quand je lance la macro, même si la cellule de la colonne O n'est pas vide, une feuille est créée.

j'ai mis en gras la ligne de double condition qui ne fonctionne pas, si quelqu'un pouvait m'aider à trouver l'erreur.

voici la macro

Code:

Sub Creer_feuilles()

'cette macro est utilisée pour créer automatiquement de nouvelles feuilles sur la base de la liste clients

Dim i, DerLigBase, lig As Integer
Dim dossier, sNomFeuille As String
Dim colFeuille As Collection
Dim rCelA As Range
Dim shAct As Worksheet
Dim FeuilleExist As Boolean

'Recherche de la dernière ligne
DerLigBase = Sheets("clients").Range("A900").End(xlUp).Row

Set colFeuille = New Collection

On Error Resume Next
'Boucle sur la plage de cellule
For Each rCelA In Sheets("clients").Range(Cells(2, 1), Cells(DerLigBase, 1))
    colFeuille.Add rCelA, CStr(rCelA)
Next rCelA

'Boucle sur les éléments de la collection pour récupérer le nom des onglets
For i = 1 To colFeuille.Count
    'Récupère le nom de l'onglet stocké dans la collection
    sNomFeuille = colFeuille.Item(i)
    'Recherche si cet onglet existe
    For Each shAct In ActiveWorkbook.Worksheets
        If StrComp(shAct.Name, sNomFeuille, vbTextCompare) = 0 Then
            FeuilleExist = True
            'Effacement des données du classeur
            Sheets(sNomFeuille).Range("A2:R2").ClearContents
            Exit For
        End If
    Next shAct
    'SI ON A PAS TROUVE LA FEUILLE ET QUE LA COLONNE O EST VIDE ON LA CREEE
  If IsEmpty(Sheets("clients").Cells(i, 15)) And FeuilleExist = False Then
        Application.ScreenUpdating = False
        'Copie le modele et on le place à la fin
        Sheets("modele").Visible = True
        ThisWorkbook.Worksheets("Modele").Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
        With ActiveSheet
            .Name = sNomFeuille
        End With
        Sheets("modele").Visible = True
        Sheets("clients").Activate
        Application.ScreenUpdating = False
    End If
    'Rebascule le boolean pour la seconde feuille
    FeuilleExist = False
Next i

'Recherche de la ligne et tri dans chaque feuille
For i = 2 To DerLigBase
    dossier = Cells(i, 1).Text
    lig = Sheets(dossier).Range("A2").End(xlUp).Row
    'Copie
    Sheets("clients").Range("A" & i & ":R" & i).Copy Destination:=Worksheets(dossier).Range("A2")
    '& Lig + 1)
    
    
Next i

MsgBox "opération effectuée"

End Sub

merci d'avance de votre attention

Robert · 21 Septembre 2012

Re : double condition ne fonctionne pas

Bonjour Superbog, bonjour le forum,

peut-être comme ça (non testé ni commenté) :

Code:

Sub macro1()
Dim dico As Object
Dim dl As Integer
Dim pl As Range
Dim cel As Range
Dim temp As Variant
Dim i As Integer
Dim o As Object
Dim test As Boolean

Application.ScreenUpdating = False
Set dico = CreateObject("Scripting.Dictionary")
With Sheets("Clients")
    dl = .Cells(Application.Rows.Count, 1).End(xlUp).Row
    Set pl = .Range("A2:A" & dl)
End With
For Each cel In pl
    dico(cel.Value) = ""
Next cel
temp = dico.keys
For i = 0 To UBound(temp, 1)
    For Each o In Sheets
        If o.Cells(i, 15) <> "" Then GoTo suite
        If StrComp(o.Name, temp(i), vbTextCompare) = 0 Then test = True
    Next o
    If test = True Then test = False: GoTo suite
    'Copie le modele et on le place à la fin
    Sheets("modele").Visible = True
    Worksheets("Modele").Copy after:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = temp(i)
    Sheets("modele").Visible = False
    Sheets("clients").Activate
suite:
    Next o
Next i
Application.ScreenUpdating = True
End Sub

superbog · 21 Septembre 2012

Re : double condition ne fonctionne pas

merci Robert mais il y a un bug
quand je lance la macro, voici la fenêtre d'erreur
"erreur de compilation
référence de variable de contrôle incorrecte dans le next"

et c'est le dernier next o qui est concerné

Robert à dit:

Bonjour Superbog, bonjour le forum,

peut-être comme ça (non testé ni commenté) :

Code:

Sub macro1()
Dim dico As Object
Dim dl As Integer
Dim pl As Range
Dim cel As Range
Dim temp As Variant
Dim i As Integer
Dim o As Object
Dim test As Boolean

Application.ScreenUpdating = False
Set dico = CreateObject("Scripting.Dictionary")
With Sheets("Clients")
    dl = .Cells(Application.Rows.Count, 1).End(xlUp).Row
    Set pl = .Range("A2:A" & dl)
End With
For Each cel In pl
    dico(cel.Value) = ""
Next cel
temp = dico.keys
For i = 0 To UBound(temp, 1)
    For Each o In Sheets
        If o.Cells(i, 15) <> "" Then GoTo suite
        If StrComp(o.Name, temp(i), vbTextCompare) = 0 Then test = True
    Next o
    If test = True Then test = False: GoTo suite
    'Copie le modele et on le place à la fin
    Sheets("modele").Visible = True
    Worksheets("Modele").Copy after:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = temp(i)
    Sheets("modele").Visible = False
    Sheets("clients").Activate
suite:
    Next o
Next i
Application.ScreenUpdating = True
End Sub

Robert · 21 Septembre 2012

Re : double condition ne fonctionne pas

Bonsoir Superbog, bonsoir el forum,

Oui désolé il y a bien sûr un Next o en trop... Le code corrigé (mais toujours pas testé)

Code:

Sub macro1()
Dim dico As Object
Dim dl As Integer
Dim pl As Range
Dim cel As Range
Dim temp As Variant
Dim i As Integer
Dim o As Object
Dim test As Boolean

Application.ScreenUpdating = False
Set dico = CreateObject("Scripting.Dictionary")
With Sheets("Clients")
    dl = .Cells(Application.Rows.Count, 1).End(xlUp).Row
    Set pl = .Range("A2:A" & dl)
End With
For Each cel In pl
    dico(cel.Value) = ""
Next cel
temp = dico.keys
For i = 0 To UBound(temp, 1)
    For Each o In Sheets
        If o.Cells(i, 15) <> "" Then GoTo suite
        If StrComp(o.Name, temp(i), vbTextCompare) = 0 Then test = True
    Next o
    If test = True Then test = False: GoTo suite
    'Copie le modele et on le place à la fin
    Sheets("modele").Visible = True
    Worksheets("Modele").Copy after:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = temp(i)
    Sheets("modele").Visible = False
    Sheets("clients").Activate
suite:
Next i
Application.ScreenUpdating = True
End Sub

superbog · 21 Septembre 2012

Re : double condition ne fonctionne pas

ca ne marche toujours pas

message d'erreur:
erreur d'exécution '1004':
erreur définie par l'application ou par l'objet

et quand je clique sur débogage, voici la ligne qui apparait en surligné

If o.Cells(i, 15) <> "" Then

Robert · 25 Septembre 2012

Re : double condition ne fonctionne pas

Bonjour Superbog, bonjour le forum,

Tu arrives à presque 200 posts dans ce forum et tu n'as toujours pas compris que sans fichier exemple il nous est difficile de comprendre ou expliquer ou vérifier un code ! C'est grave... Je te l'ai dit deux fois indirectement (non testé) pourtant !...

superbog · 25 Septembre 2012

Re : double condition ne fonctionne pas

désolée Robert, je suis très fatiguée et je n'ai pas compris

pour moi ça voulait dire que tu n'avais pas eu le temps...
mille excuses

ci dessous le fichier test

Robert à dit:
Bonjour Superbog, bonjour le forum,

Tu arrives à presque 200 posts dans ce forum et tu n'as toujours pas compris que sans fichier exemple il nous est difficile de comprendre ou expliquer ou vérifier un code ! C'est grave... Je te l'ai dit deux fois indirectement (non testé) pourtant !...

Robert · 25 Septembre 2012

Re : double condition ne fonctionne pas

Bonjour Superbog, bonjour le forum,

Grâce au fichier j'ai pu tester et déceler l'erreur (i au lieu de temp(i)). Le code modifié :

Code:

Sub macro1()
Dim dico As Object
Dim dl As Integer
Dim pl As Range
Dim cel As Range
Dim temp As Variant
Dim i As Integer
Dim o As Object
Dim test As Boolean

Application.ScreenUpdating = False
Set dico = CreateObject("Scripting.Dictionary")
With Sheets("Clients")
    dl = .Cells(Application.Rows.Count, 1).End(xlUp).Row
    Set pl = .Range("A2:A" & dl)
End With
For Each cel In pl
    dico(cel.Value) = ""
Next cel
temp = dico.keys
For i = 0 To UBound(temp, 1)
    For Each o In Sheets
        If o.Cells(temp(i), 15) <> "" Then GoTo suite
        If StrComp(o.Name, temp(i), vbTextCompare) = 0 Then
            test = True
            Exit For
        End If
    Next o
    If test = True Then test = False: GoTo suite
    'Copie le modele et on le place à la fin
    Sheets("modele").Visible = True
    Worksheets("Modele").Copy after:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = temp(i)
    Sheets("modele").Visible = False
    Sheets("clients").Activate
suite:
Next i
Application.ScreenUpdating = True
End Sub

superbog · 25 Septembre 2012

Re : double condition ne fonctionne pas

désolée mais ca ne fonctionne toujours pas
ca mouline un certain temps, ca créée des feuilles qui existent déjà puis ca s'arrete
et le débogeur indique que l'erreur est ici

If o.Cells(temp(i), 15) <> "" Then

Robert · 25 Septembre 2012

Re : double condition ne fonctionne pas

Bonjour Superbog, bonjour le froum,

Oui désolé... J'avais testé chez moi et ça ne plantait pas mais je n'avais même pas pris le temps de regarder le résultat. J'ai donc modifié et simplifié le code et je pense que, cette fois, ça devrait correspondre :

Code:

Sub macro1()
Dim dl As Integer 'déclare la variable dl (Dernière Ligne)
Dim i As Integer 'déclare la variable i (Incrément)
Dim o As Object 'déclare la variable o (Onglet)

Application.ScreenUpdating = False 'masque les changements à l''ecran
With Sheets("Clients") 'prend en compte l'onglet "Clients"
    dl = .Cells(Application.Rows.Count, 1).End(xlUp).Row 'définit la dernière ligne éditée de la colonne 1 (=A)
    For i = 2 To dl 'boucle des lignes 2 à dl
        If .Cells(i, 15).Value <> "" Then GoTo suite 'si la cellule de la boucle en colonne 15 n'est pas vide, va à l'étiquette "suite"
        On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
        Set o = Sheets(CStr(.Cells(i, 1).Value)) 'définit l'onglet o (génère une erreur si c'est onglet n'existe pas)
        If Err <> 0 Then 'condition : si une erreur a été générée
            Err = 0 'annule l'erreur
            'Copie le modele et on le place à la fin
            Sheets("modele").Visible = True
            Worksheets("Modele").Copy after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = .Cells(i, 1)
            Sheets("modele").Visible = False
            Sheets("clients").Activate
        End If 'fin de la condition
        On Error GoTo 0 'annule la gestion des ereurs
suite: 'étiquette
    Next i 'prochaine ligne de la boucle
End With 'fin de la pise en compte de l'onglet "Clients"
Application.ScreenUpdating = True 'affiche les changements à l'écran
End Sub

superbog · 26 Septembre 2012

Re : double condition ne fonctionne pas

merci Robert ca fonctionne parfaitement mais comment puis je faire pour poser une autre condition

que les indications des colonnes du fichiers clients soient les mêmes dans le fichier dossier
en effet parfois les adresses ou les emails des gens changent et je voudrais pouvoir mettre les dossiers à jour

superbog · 16 Octobre 2012

Re : double condition ne fonctionne pas

je me permets de relancer ma question ...

Effectuez une recherche sur Excel Downloads...

double condition ne fonctionne pas

superbog

XLDnaute Occasionnel

Robert

XLDnaute Barbatruc

superbog

XLDnaute Occasionnel

Robert

XLDnaute Barbatruc

superbog

XLDnaute Occasionnel

Robert

XLDnaute Barbatruc

superbog

XLDnaute Occasionnel

Pièces jointes

Robert

XLDnaute Barbatruc

superbog

XLDnaute Occasionnel

Robert

XLDnaute Barbatruc

superbog

XLDnaute Occasionnel

superbog

XLDnaute Occasionnel

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums