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

N
  • Résolu(e)
XL 2021 comment faire recherche dans une colonne et ligne
Réponses
5
Affichages
289
job75
job75
E
  • Question
Power Query Index TP de l'INSEE - Ajuster une formule à chaque mise à jour d'un tableau généré avec PQ
2
Réponses
21
Affichages
655
laurent950
laurent950
M
  • Question
Microsoft 365 Indice de révision de chaque ligne automatiquement
Réponses
2
Affichages
130
MLIZIN
M
E
  • Résolu(e)
XL 2019 transfer listbox vers une colonne à partir de la 4 ligne
Réponses
2
Affichages
91
escudo
E
T
  • Question
XL 2021 Reporter sous forme de liste dans une cellule les donnés contenues dans plusieurs cellules et cela sous condition
Réponses
2
Affichages
112
thioff
T
T
  • Résolu(e)
XL 2016 macro et feuille protégé
2
Réponses
18
Affichages
444
laurent950
laurent950
T
  • Résolu(e)
XL 2019 Contrôle de saisie d'heures
Réponses
10
Affichages
296
ThierryP
T
Nicolas JACQUIN
  • Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
831
Nicolas JACQUIN
Nicolas JACQUIN
N
  • Résolu(e)
Microsoft 365 Rechercher la dernière cellule saisie dans un TS et ajouter l'heure système
17 18 19
Réponses
277
Affichages
64 K
NONO14
N
J
  • Question
Microsoft 365 Ajouter une colonne
Réponses
0
Affichages
362
Juliopapadopulos
J

Membres actuellement en ligne

17 membres et 321 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 422
Messages
2 109 447
Membres
110 482
dernier inscrit
ilyxxxh