XL 2013 Interdire saisie de doublon et faire synthèse à chaque saisie

B

BIROULIG

XLDnaute Nouveau
Bonjour, je sollicite à nouveau votre aide , je toujours débutant.
Actuellement je dois regroupé 4 liste de câbles qui sont renseigner en colonnes A . Listes provenant de différents services avec des lignes vides parfois et
le nombres est susceptible d'augmenté c'est pour cette raison que j'utilise parfois le n° de la feuille.
Je désire qu'en feuil 5 ("liste") dresser la liste de tout les câbles en colonnes A en enlevant les ligne vides et en colonnes B je mets le nom de le la feuille ex "L3 36437625"
que désigne a un lieu et son numéro barbare. ça j'y suis arrive en module 1.

J'ai trouvé dans le forum des discussions un peu similaire mais je n'ai pas réussi à l'adapter à mon problème.


Sub Synthese()

Dim LPREMCABLE As Integer 'Ligne du premier câble de la page source
Dim CASEPLEINE As Integer 'Nombre de cellule pleine en colonne "A" source
Dim INDEX As Variant
Dim PAGE As Integer
Worksheets("LISTE").Range("A2:G1000").ClearContents
PAGE = 1
INDEX = 2
For PAGE = 1 To 4
With Worksheets(PAGE)
CASEPLEINE = 0
LPREMCABLE = 5

For Each c In Worksheets(PAGE).Range("A5:A28")
If c.Value > 0 Then
CASEPLEINE = CASEPLEINE + 1
End If
Next c
' Copy
Worksheets(PAGE).Range("A5 : D27").Copy Destination:=Sheets("LISTE").Range("A" & (2 + INDEX))
End With

With Sheets("LISTE").Activate 'Mis With car sans sans ne marche pas à chaque fois

' Suppression des lignes vides
Range(Cells(INDEX, 1), Cells(65000, 1)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
' Renseignement de la page dans la deuxieme colonne
Range(Cells(INDEX, 2), Cells(INDEX + CASEPLEINE - 1, 2)).Value = Worksheets(PAGE).Name
' Indexation de la drnière ligne pleine
INDEX = INDEX + CASEPLEINE
End With
Next PAGE

End Sub

Mais je désirerai pouvoir que sur les feuilles 1 à 4 lorsque quelqu'un rajoute un câble la saisie soit rejetée
s'il existe déjà sur une de 4 feuille et donc aussi en feuille 5 et que l'on affiche un msgbox
et si c'est un nouveau pouvoir continuer la saisie et le rajouter automatiquement en feuille 5.
Je désire également reseter la feuille 5 par le code plus haut si je reçois une nouvelle feuille.
En espérant avoir été assez clair. Je préfère une solution longue mais accessible pour un débutant.

Merci pour votre aide.
 

Pièces jointes

  • CLASSEUR.xls
    69 KB · Affichages: 6
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Bonjour BIROULIG, François,

Voyez le fichier joint.

J'ai commencé par effacer les doublons, il y en avait un en 1ère feuille (F113) et un en 4ème feuille (F105).

La macro dans ThisWorkbook pour contrôler les entrées en colonne A des feuilles :
VB: 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If UCase(CStr(Sh.[A4])) <> "REFERENCE" Then Exit Sub
Set Target = Intersect(Target, Sh.Range("A5:A" & Sh.Rows.Count))
If Target Is Nothing Then Exit Sub
Application.EnableEvents = False 'désactive les évènements
If Target.Count > 1 And Application.CountA(Target) > 0 Then _
    MsgBox "Entrées multiples non autorisées en colonne A...": Application.Undo: GoTo 1 'annule l'entrée:GoTo 1
Dim x$, w As Worksheet
x = CStr(Target(1))
If x = "" Then GoTo 1
If Left(x, 1) <> "F" Then MsgBox "La référence doit commencer par F...": Application.Undo: GoTo 1
For Each w In Worksheets
    If UCase(CStr(w.Range("A4"))) = "REFERENCE" Then _
        If Application.CountIf(w.Columns(1), x) > -(w.Name = Sh.Name) Then _
            MsgBox "La référence '" & x & "' est déjà utilisée, l'entrée va être annulée !", 48: Application.Undo: GoTo 1
Next
1 Application.EnableEvents = True 'réactive les évènements
End Sub
La macro dans la feuille "LISTE" pour créer le tableau :
VB: 
Private Sub Worksheet_Activate()
Dim w As Worksheet, tablo, i&, n&, resu()
For Each w In Worksheets
    If UCase(CStr(w.Range("A4"))) = "REFERENCE" Then
        tablo = w.Range("A4:D" & w.Cells.SpecialCells(xlCellTypeLastCell).Row) 'matrice, plus rapide
        For i = 2 To UBound(tablo)
            If Left(tablo(i, 1), 1) = "F" Then
                n = n + 1
                ReDim Preserve resu(1 To 4, 1 To n)
                resu(1, n) = tablo(i, 1)
                resu(2, n) = w.Name
                resu(3, n) = tablo(i, 3)
                resu(4, n) = tablo(i, 4)
            End If
        Next i
    End If
Next w
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2] '1ère cellule de destination
    If n Then .Resize(n, 4) = Application.Transpose(resu) 'Transpose est limitée à 65536 lignes
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 4).ClearContents 'RAZ en dessous
End With
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub
Elle se déclenche quand on active la feuille.

A+
 

Pièces jointes

  • CLASSEUR(1).xls
    79 KB · Affichages: 8
Vote positif 0 Vote négatif
B

BIROULIG

XLDnaute Nouveau
fanfan38 à dit:
Bonjour et bienvenu sur Excel Download
Tu n'as pas renseigné la version d'Excel....
Ci joint ma solution

A+ François
Cliquez pour agrandir...
Bonjour François, et désolé pour la réponse tardive, j'ai scratché mon PC ce W.E.
Toujours aussi prompt à répondre.
Je regarde cette semaine... Et je suis en excel 2013 et microsoft 365, j'avais oublié les règles depuis ma dernières discussion désolé.
Merci
 
Vote positif 0 Vote négatif
B

BIROULIG

XLDnaute Nouveau
job75 à dit:
Bonjour BIROULIG, François,

Voyez le fichier joint.

J'ai commencé par effacer les doublons, il y en avait un en 1ère feuille (F113) et un en 4ème feuille (F105).

La macro dans ThisWorkbook pour contrôler les entrées en colonne A des feuilles :
VB: 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If UCase(CStr(Sh.[A4])) <> "REFERENCE" Then Exit Sub
Set Target = Intersect(Target, Sh.Range("A5:A" & Sh.Rows.Count))
If Target Is Nothing Then Exit Sub
Application.EnableEvents = False 'désactive les évènements
If Target.Count > 1 And Application.CountA(Target) > 0 Then _
    MsgBox "Entrées multiples non autorisées en colonne A...": Application.Undo: GoTo 1 'annule l'entrée:GoTo 1
Dim x$, w As Worksheet
x = CStr(Target(1))
If x = "" Then GoTo 1
If Left(x, 1) <> "F" Then MsgBox "La référence doit commencer par F...": Application.Undo: GoTo 1
For Each w In Worksheets
    If UCase(CStr(w.Range("A4"))) = "REFERENCE" Then _
        If Application.CountIf(w.Columns(1), x) > -(w.Name = Sh.Name) Then _
            MsgBox "La référence '" & x & "' est déjà utilisée, l'entrée va être annulée !", 48: Application.Undo: GoTo 1
Next
1 Application.EnableEvents = True 'réactive les évènements
End Sub
La macro dans la feuille "LISTE" pour créer le tableau :
VB: 
Private Sub Worksheet_Activate()
Dim w As Worksheet, tablo, i&, n&, resu()
For Each w In Worksheets
    If UCase(CStr(w.Range("A4"))) = "REFERENCE" Then
        tablo = w.Range("A4:D" & w.Cells.SpecialCells(xlCellTypeLastCell).Row) 'matrice, plus rapide
        For i = 2 To UBound(tablo)
            If Left(tablo(i, 1), 1) = "F" Then
                n = n + 1
                ReDim Preserve resu(1 To 4, 1 To n)
                resu(1, n) = tablo(i, 1)
                resu(2, n) = w.Name
                resu(3, n) = tablo(i, 3)
                resu(4, n) = tablo(i, 4)
            End If
        Next i
    End If
Next w
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2] '1ère cellule de destination
    If n Then .Resize(n, 4) = Application.Transpose(resu) 'Transpose est limitée à 65536 lignes
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 4).ClearContents 'RAZ en dessous
End With
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub
Elle se déclenche quand on active la feuille.

A+
Cliquez pour agrandir...
Bonjour, et désolé pour la réponse tardive, j'ai scratché mon PC ce W.E.
Les 2 doublons sans doutes des restes de mes essais. Je regarde cette semaine en essayant de comprendre...
Merci
 
Vote positif 0 Vote négatif
B

BIROULIG

XLDnaute Nouveau
job75 à dit:
Bonjour BIROULIG, François,

Voyez le fichier joint.

J'ai commencé par effacer les doublons, il y en avait un en 1ère feuille (F113) et un en 4ème feuille (F105).

La macro dans ThisWorkbook pour contrôler les entrées en colonne A des feuilles :
VB: 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If UCase(CStr(Sh.[A4])) <> "REFERENCE" Then Exit Sub
Set Target = Intersect(Target, Sh.Range("A5:A" & Sh.Rows.Count))
If Target Is Nothing Then Exit Sub
Application.EnableEvents = False 'désactive les évènements
If Target.Count > 1 And Application.CountA(Target) > 0 Then _
    MsgBox "Entrées multiples non autorisées en colonne A...": Application.Undo: GoTo 1 'annule l'entrée:GoTo 1
Dim x$, w As Worksheet
x = CStr(Target(1))
If x = "" Then GoTo 1
If Left(x, 1) <> "F" Then MsgBox "La référence doit commencer par F...": Application.Undo: GoTo 1
For Each w In Worksheets
    If UCase(CStr(w.Range("A4"))) = "REFERENCE" Then _
        If Application.CountIf(w.Columns(1), x) > -(w.Name = Sh.Name) Then _
            MsgBox "La référence '" & x & "' est déjà utilisée, l'entrée va être annulée !", 48: Application.Undo: GoTo 1
Next
1 Application.EnableEvents = True 'réactive les évènements
End Sub
La macro dans la feuille "LISTE" pour créer le tableau :
VB: 
Private Sub Worksheet_Activate()
Dim w As Worksheet, tablo, i&, n&, resu()
For Each w In Worksheets
    If UCase(CStr(w.Range("A4"))) = "REFERENCE" Then
        tablo = w.Range("A4:D" & w.Cells.SpecialCells(xlCellTypeLastCell).Row) 'matrice, plus rapide
        For i = 2 To UBound(tablo)
            If Left(tablo(i, 1), 1) = "F" Then
                n = n + 1
                ReDim Preserve resu(1 To 4, 1 To n)
                resu(1, n) = tablo(i, 1)
                resu(2, n) = w.Name
                resu(3, n) = tablo(i, 3)
                resu(4, n) = tablo(i, 4)
            End If
        Next i
    End If
Next w
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2] '1ère cellule de destination
    If n Then .Resize(n, 4) = Application.Transpose(resu) 'Transpose est limitée à 65536 lignes
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 4).ClearContents 'RAZ en dessous
End With
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub
Elle se déclenche quand on active la feuille.

A+
Cliquez pour agrandir...
Je viens de tester c'est plus que je voulais et ç correspond à 100% je vais regarder la Réponse à FANFAN et il va me falloir choisir la solution la plus à ma portée.

Merci JOB
 
Vote positif 0 Vote négatif

Discussions similaires

PORCHER
  • Question
Microsoft 365 L'indice n'appartient pas à la sélection
Réponses
8
Affichages
299
TooFatBoy
TooFatBoy
Z
  • Question
Microsoft 365 Validation de données et saisie partielle
Réponses
3
Affichages
116
Dranreb
Dranreb
Y
  • Question
Microsoft 365 Insérer des lignes selon variable
Réponses
1
Affichages
222
gbinforme
G
L
  • Question
VBA : erreur sur boucle
Réponses
2
Affichages
63
Latias
L
M
  • Question
Microsoft 365 Copier / coller avec mise en forme VBA
Réponses
0
Affichages
128
marie3107
M
Z
  • Résolu(e)
Microsoft 365 Récupérer les éléments d'une liste en fonction de leur position
Réponses
2
Affichages
213
Zarnir
Z
halecs93
  • Résolu(e)
XL 2016 Indice n'appartient pas à la sélection : HELP !!!!
2
Réponses
21
Affichages
526
halecs93
halecs93
C
  • Résolu(e)
XL 2013 Impression auto par rapport à une liste
2
Réponses
16
Affichages
613
candido57
C
F
  • Résolu(e)
Microsoft 365 Recherche à partir d'une TextBox
Réponses
4
Affichages
141
Francky79
F
H
  • Question
XL 2021 Macro en vba
Réponses
4
Affichages
198
Lolote83
L

Membres actuellement en ligne

11 membres et 128 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 104
Messages
2 085 335
Membres
102 864
dernier inscrit
abderrashmaen