Dev Faq
1
votes

Comment puis-je créer une boucle pour exécuter ce code 15 fois en utilisant une liste des variables de plage que j'ai définies?

J'exécute le même code pour chacune des 15 plages statiques de l'événement Worksheet_Change (actuel). Chaque plage est évaluée par elle-même.

Je recherche les doublons, mais pas entre les plages, uniquement dans chaque plage individuelle. Mais toutes les plages doivent être vérifiées (ou jusqu'à l'action) avant la fin de la procédure.

Les cellules sont remplies par des sélections d'utilisateurs à partir de listes déroulantes dynamiques pour toutes les cellules.

Le code que je publie fonctionne exactement comme j'en ai besoin. Comment puis-je faire une boucle pour exécuter le même code 15 fois en utilisant une liste des variables de plage que j'ai définies?

Je veux simplifier le code afin que si je modifie le code, je ne le fais pas Je dois le changer à 15 endroits.

J'ai essayé plusieurs versions de code recherché pour rendre un code en boucle fonctionnel, mais les multiples instructions If me rendent difficile de trouver la bonne structure pour une boucle.

J'ai finalement abandonné et copié le code 15 fois dans une instruction If - ElseIf qui fonctionne. 

Private Sub Worksheet_Change(ByVal Target As Range)

'Define your variables.
Dim Sun1AM As Range, Sun1PM As Range, Wed1PM As Range
Dim Sun2AM As Range, Sun2PM As Range, Wed2PM As Range
Dim Sun3AM As Range, Sun3PM As Range, Wed3PM As Range
Dim Sun4AM As Range, Sun4PM As Range, Wed4PM As Range
Dim Sun5AM As Range, Sun5PM As Range, Wed5PM As Range

'Set the ranges where you want to prevent duplicate entries.
Set Sun1AM = Range("C4:C14")
Set Sun1PM = Range("C17:C21")
Set Wed1PM = Range("C24:C28")
Set Sun2AM = Range("E4:E14")
Set Sun2PM = Range("E17:E21")
Set Wed2PM = Range("E24:E28")
Set Sun3AM = Range("G4:G14")
Set Sun3PM = Range("G17:G21")
Set Wed3PM = Range("G24:G28")
Set Sun4AM = Range("I4:I14")
Set Sun4PM = Range("I17:I21")
Set Wed4PM = Range("I24:I28")
Set Sun5AM = Range("K4:K14")
Set Sun5PM = Range("K17:K21")
Set Wed5PM = Range("K24:K28")


'See if target is in any of the ranges defined above and check for 
'duplicates range by range.
If Not Intersect(Target, Sun1AM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Sun1AM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _ 
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Sun1PM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Sun1PM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Wed1PM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Wed1PM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Sun2AM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Sun2AM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Sun2PM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Sun2PM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Wed2PM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Wed2PM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Sun3AM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Sun3AM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Sun3PM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Sun3PM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Wed3PM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Wed3PM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Sun4AM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Sun4AM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Sun4PM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Sun4PM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Wed4PM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Wed4PM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Sun5AM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Sun5AM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Sun5PM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Sun5PM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Wed5PM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Wed5PM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

Else
    Exit Sub

End If

End Sub

Cela fonctionne mais très difficile à gérer. Quelqu'un, s'il vous plaît, éclairez-moi à une belle boucle simple. Je vais copier cette feuille, en faire une nouvelle copie chaque mois, donc le code doit rester "feuille courante" et travailler sur n'importe quelle feuille sur laquelle l'utilisateur travaille.

Merci beaucoup !!!

0 commentaires

3 Réponses :

1
votes

Quelque chose comme ceci: 

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rng As Range, a As Range

    If Target.CountLarge > 1 Then Exit Sub 'only need this test once

    Set rng = Me.Range("C4:C14,C17:C21,C24:C28") 'start here
    Do While rng.Column <= 11
        'loop over the areas in the range
        For Each a In rng.Areas
            'edit 2 missed this entire check...
            If not Application.Intersect(a, Target) Is Nothing Then
                If Application.CountIf(a, Target.Value) > 1 Then
                    MsgBox Target.Value & " is already used in range " & a.Address, _
                           vbInformation, "Duplicate Entry!"
                    Exit Do
                End If
            End If

        Next a
        Set rng = rng.Offset(0, 2) 'move two columns to the right
    Loop

End Sub

5 commentaires

Ce code déclenche la boîte de message avec n'importe quelle entrée n'importe où dans l'une des plages. Même si l'entrée n'est pas un doublon. Je ne veux tirer que s'il y a un doublon dans la plage où se trouve la cible.

Mon mauvais, j'avais countif> 0 et pas> 1

Je ne peux pas croire que j'ai raté ça. Je l'ai revu 10 fois. J'ai rajouté dans la ligne pour vérifier si le doublon était dans la même plage que la cible. Vous pouvez me dire si je n'en ai pas besoin. 'If Not Intersect (Target, a) Is Nothing And WorksheetFunction.CountIf (a, Target.Value)> 1 Then MsgBox Target.Value & "est déjà utilisé", _ vbInformation, "Duplicate Entry!"' Cela fonctionne totalement maintenant.

Vous avez raison, j'ai raté le test Cible / Intersection - c'est ce qui se passe lorsque vous sautez le test ...

J'ai eu besoin du code ci-dessus pour vérifier si la cible était dans la plage actuelle. Sinon, la boîte de message en double s'est déclenchée lorsque la cible était en dehors de l'une des plages mais que le nom était déjà utilisé dans l'une des plages. Tu as fais un travail extraordinaire. Merci beaucoup. Je publierai mon code final comme réponse.

0
votes

Si le modèle de plages est exactement le même, vous pouvez essayer 

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub

Dim SrcRng(1 To 15) As Range
Dim i As Long

Set SrcRng(1) = Range("C4:C14")
Set SrcRng(2) = Range("C17:C21")
Set SrcRng(3) = Range("C24:C28")
Set SrcRng(4) = Range("E4:E14")
Set SrcRng(5) = Range("E17:E21")
Set SrcRng(6) = Range("E24:E28")
Set SrcRng(7) = Range("G4:G14")
Set SrcRng(8) = Range("G17:G21")
Set SrcRng(9) = Range("G24:G28")
Set SrcRng(10) = Range("I4:I14")
Set SrcRng(11) = Range("I17:I21")
Set SrcRng(12) = Range("I24:I28")
Set SrcRng(13) = Range("K4:K14")
Set SrcRng(14) = Range("K17:K21")
Set SrcRng(15) = Range("K24:K28")


        For i = 1 To 15
        'See if target is in any of the ranges defined above and check for
        'duplicates range by range.
            If Not Intersect(Target, SrcRng(i)) Is Nothing Then
            If WorksheetFunction.CountIf(SrcRng(i), Target.Value) > 1 Then _
            MsgBox Target.Value & " is already used.", vbInformation, _
            "Duplicate Entry!"
            Exit For
            End If
      Next i
End Sub

Ou bien si les plages exigent que d soit testé ne suit pas toujours un modèle, vous pouvez essayer 

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
Dim SrcRng As Range, URng As Range
Dim Cl As Long, EndRw As Long, StartRw As Long, EndRwID As Long

    For Cl = 3 To 11 Step 2
        For EndRwID = 2 To 4
        EndRw = EndRwID * 7
        StartRw = IIf(EndRwID = 2, EndRw - 10, EndRw - 4)
        Set SrcRng = Range(Cells(StartRw, Cl), Cells(EndRw, Cl))

        'See if target is in any of the ranges defined above and check for
        'duplicates range by range.
            If Not Intersect(Target, SrcRng) Is Nothing Then
                If WorksheetFunction.CountIf(SrcRng, Target.Value) > 1 Then _
                MsgBox Target.Value & " is already used.", vbInformation, _
                "Duplicate Entry!"
            Exit For
            End If

    Next EndRwID
    Next Cl
End Sub

1 commentaires

Comme je travaillais déjà avec la solution Tim Williams, j'étais loin d'avoir terminé cette tâche. S'il vous plaît voir mon code final posé ci-dessus pour ce qui a fonctionné et quelles modifications j'ai apportées au code soumis par Tim.

0
votes

Réponse gracieuseté de Tim Williams (voir l'article ci-dessus) https://stackoverflow.com/users/478884/tim-williams

Remarque: ce code vérifie si l'utilisateur saisit une valeur en double dans les plages C4: C14, C17: C21, C24: C28, E4: E14, E17: E21, E24: E28, G4: G14, G17: G21, G24: G28, I4: I14, I17: I21, I24: I28, K4: K14, K17: K21, K24: C28 uniquement.

Il s'agit de plages statiques d'affectations sur un calendrier d'affectation mensuel dynamique. Ce code ne supprime ni n'empêche une entrée en double. Il informe uniquement l'utilisateur avec une boîte de message vbInformation qu'une personne a reçu plus d'une tâche un jour donné. Il notifie que "quelqu'un" a déjà été utilisé, et l'utilisateur peut choisir de laisser ou de modifier le duplicata. Cette feuille (une copie principale) est copiée comme une nouvelle feuille vierge pour chaque mois, les devoirs sont remplis et des copies imprimées sont distribuées. La feuille elle-même change de manière dynamique pour refléter les dates calendaires appropriées une fois par mois et l'année est choisie. Ce code est conçu pour fonctionner sur la feuille de calcul "active" car un seul mois (une feuille) est attribué à la fois, et les mois passés restent comme documents de référence. 

Private Sub Worksheet_Change(ByVal Target As Range)    'By Tim Williams

Dim rng As Range, a As Range

If Target.CountLarge > 1 Then Exit Sub 'only need this test once
If IsEmpty(Target) Then Exit Sub       'added check for empty target on delete action

Set rng = Range("C4:C14,C17:C21,C24:C28") 'start here
Do While rng.Column <= 11
    'loop over the areas in the range
    For Each a In rng.Areas
        If Not Intersect(Target, a) Is Nothing _
           And WorksheetFunction.CountIf(a, Target.Value) > 1 Then
            MsgBox Target.Value & " is already used", _
            vbInformation, "Duplicate Entry!"

            Exit Do
        End If    

    Next a
    Set rng = rng.Offset(0, 2) 'move two columns to the right
Loop

End Sub

Un grand merci à Tim de m'avoir montré comment simplifier mon code volumineux en une routine incroyablement soignée et simple.

0 commentaires

Articles qui pourrait vous intéresser :

Comment amener quatre colonnes de données Excel en deux lignes dans Pandas
AttributeError: l'objet 'ElementTree' n'a pas d'attribut 'getiterator' lors de la tentative d'importation d'un fichier Excel
La fenêtre de l'application EXCEL ne se ferme pas sur classeur.close ()
Exécuter la macro lorsque le résultat de la cellule change par formule