Numérotation de ligne automatique
Bonjour le Forum
Voici un fichier que je souhaite amélioré suivant ces 2 actions:
1- Numéroter automatiquement la nouvelle ligne insérée avec le Btn "Nouvelle Entrée de l'Userform Gestion du tableau de bord
Voici le code en place:
'PROCEDURE AJOUT ENREGISTREMENT DANS FEUILLE "DataBase"
Private Sub BtnAjout_Click()
'Déclaration des variables
Dim lo As ListObject
Dim rCell As Range
Dim bAutoExpand As Boolean, bAutoFill As Boolean
'options de l'application pour la correction automatique
'(Options Excel, Vérification...)
With Application.AutoCorrect
'on mémorise l'état des 2 propriétés
bAutoExpand = .AutoExpandListRange 'insertion de lignes dans les listes ou tables (tableaux)
bAutoFill = .AutoFillFormulasInLists 'formules de remplissage colonnes calculées
.AutoExpandListRange = True 'on autorise...
.AutoFillFormulasInLists = True 'on autorise...
End With
'initialisation de la table (tableau)
Set lo = Worksheets("DataBase").ListObjects("TDataBase")
With lo
'Si la table comporte des données
If .InsertRowRange Is Nothing Then
'1ère. cellule vide (colonne 1 de la table,nombre de lignes de la table+1)
Set rCell = .HeaderRowRange.Cells(1).Offset(.ListRows.Count + 1)
Else
'1ère cellule colonne 1 de la table
Set rCell = .InsertRowRange.Cells(1)
End If
End With
'Restitution des données dans la feuille de calcul
With rCell
.Offset(, 1).Value = CboSecteur_Exploitation
.Offset(, 2).Value = CboEquipement
.Offset(, 3).Value = CboSocInt
.Offset(, 4).Value = CboSocExt
.Offset(, 5).Value = CboContact
.Offset(, 6).Value = TxtNumTel
.Offset(, 7).Value = TxtPriorite
.Offset(, 8).Value = TxtDDO
.Offset(, 9).Value = TxtDFO
.Offset(, 10).Value = CboNumSemPTot
.Offset(, 11).Value = CboNumSemPTard
.RowHeight = Sheets("Administrateur").[W5].Value 'Mettre la ligne à la hauteur suivant valeur cel W5 Feuil Admin
End With
'on rétablit les valeurs des 2 propriétés de la correction automatique CDbl(txtEcritFeuille.Value)
With Application.AutoCorrect
.AutoExpandListRange = bAutoExpand
.AutoFillFormulasInLists = bAutoFill
End With
End SubJ'ai essayé avec la fonction Ligne(A1) en A5 ds la feuille DataBase,
Si ds la feuille "Tableau de bord" je sélectionne ds "choix Semaine SDO" 11 par exemple et que je valide par le Btn Validation Extraction,
Cela ne correspond pas à la numérotation de la feuille "DataBase" puisque la formule est copiée aussi.
2- Modifier la valeur de la colonne M dans la feuille tableau de bord qui sera reporter aussi dans la feuille DataBase.
Dans la feuille "DataBase" en colonne "M", il est possible de modifier la valeur suivant une Abréviation ( voir dans la feuille "Administrateur")
Ce que j'aimerai, c'est faire la même chose en en feuille "Tableau de Bord", j'ai préparé le tableau pour cela (Voir Feuille "Administrateur"), et c'est pour cela qu'il faut un numéro de ligne pour pouvoir faire cette action ( Enfin c'est ce que je pense) .
Car si je modifie en colonne "M" de la feuille "Tableau de Bord", cela doit faire la modification aussi dans la feuille "DataBase"
Voici le code qui se trouve dans la feuille "Tableau de Bord"
Private Sub Worksheet_Change(ByVal Target As Range)
Dim datas, pl As Range, C As Range, c2 As Range, i As Long, tmp
datas = [T_MotsCles_TDB].Value
For i = 1 To UBound(datas)
' ref Plage de cellules impactées
tmp = Split(Replace(datas(i, 2), "=", "!"), "!")
On Error GoTo suite
Set pl = Intersect(Target, Sheets(tmp(1)).Range(tmp(2)))
On Error GoTo -1
If Not pl Is Nothing Then
' pour chaque cellule modifiée
For Each C In pl
If Not C.HasFormula Then
If LCase(Target.Formula) = LCase(datas(i, 1)) Or LCase(Target.Formula) = LCase(datas(i, 3)) Then
Set c2 = [T_MotsCles_TDB].Cells(i, 3) ' cell des formats
Application.EnableEvents = False
' nouvelle valeur
Target = c2.Value
Application.EnableEvents = True
With c2
C.Interior.Color = IIf(.Interior.Color = 16777215, xlNone, .Interior.Color)
With .Font
C.Font.Name = .Name
C.Font.Size = .Size
C.Font.Color = .Color
C.Font.FontStyle = .FontStyle
End With
C.HorizontalAlignment = .HorizontalAlignment
C.VerticalAlignment = .VerticalAlignment
C.IndentLevel = .IndentLevel
End With
Exit For
End If
End If
Next C
End If
suite:
On Error GoTo -1
Next i
End SubDans le fichier ce code est en commentaire , car quand j'utilise le Btn "Validation Extraction" cela ralenti énormément l’exécution du programme.
J'espère que ma demande est suffisamment claire pour vous, et merci de votre aide
à Bientôt
Salut Ledzep
Pour commencer, pourquoi ne pas utiliser de TS (tableaux Structurés)
Ensuite pour les numéros, pourquoi ne pas utiliser de formule du genre A de la ligne précédente +1 ?
Sinon dans la sub BtnAjout_Click()
'Restitution des données dans la feuille de calcul
With rCell
.Value = .Offset(-1, 0).Value + 1
...A+
Re le Forum
Bonjour BrunoM45 , merci de m'avoir lu et répondu.
pourquoi ne pas utiliser de formule du genre A de la ligne précédente +1 ?
Oui j'y ai pensée puisque j'ai essayé d'utiliser Ligne (A5) et cela fonctionne.
Pour être plus précis, La feuille "DataBase" sert de support pour l'enregistrement d'une nouvelle entrée ou pour la modification d'une ligne .
le tri se fait en fonction :
Private Sub Worksheet_Activate()
Dim lo As ListObject
'#Cacher UserForm
frmGestion.Hide
Application.ScreenUpdating = False
Set lo = Me.ListObjects(1)
With lo
'On Trie du plus petit au plus grand la colonne "11=K" SDO
.Sort.SortFields.Add .ListColumns(11).DataBodyRange, xlSortOnValues, xlAscending, DataOption:=xlSortNormal
'On Trie du plus petit au plus grand la colonne "9=I" DDO
.Sort.SortFields.Add .ListColumns(9).DataBodyRange, xlSortOnValues, xlAscending, DataOption:=xlSortNormal
'On Trie du plus petit au plus grand la colonne "12=L" SFO
.Sort.SortFields.Add .ListColumns(12).DataBodyRange, xlSortOnValues, xlAscending, DataOption:=xlSortNormal
.Sort.Apply
'On efface les objets définis au préalable
.Sort.SortFields.Clear
End With
Set lo = Nothing
End Subdonc la méthode que tu proposes fonctionne pour un enregistrement, mais pas si je modifie la date d'une ligne.
Cela j'ai oublié de le préciser, désolé
en fait je pense qu'il faut que je m'oriente plutôt vers :
'# PROCEDURE CHARGEMENT DES DONNÉES DEPUIS DATABASE SUIVANT CHOIX DS "CboNsem_Fin"
Private Sub BtnValid_ExtracSDO_Click()
Dim Lg As Long
Dim D1$, D2$
Dim WsS As Worksheet
'On efface la zone du Tbl de bord pour recevoir nouvelles données
Lg = Range("A8").End(xlUp).Row + 1
With Range("A" & Lg & ":A600").EntireRow
.Delete
'Identification de la feuille objet
Set WsS = Worksheets("DataBase")
With WsS.ListObjects("TDataBase")
'On Filtre sur SDO CboNsem_Fin
.Range.AutoFilter field:=11, Criteria1:="<=" & CboNsem_Fin
'On Filtre sur les Cloturés
.Range.AutoFilter field:=13, Criteria1:=" <>Cloturé"
'On Copie vers Tableau de Bord a partir de A8
.DataBodyRange.Copy [A8]
'On Réinitialiser le filtre du Tableau DataBase SDO
.Range.AutoFilter field:=11
'On Réinitialiser le filtre du Tableau DataBase
.Range.AutoFilter field:=13
End With
End With
'On sélectionne depuis la colonne A ligne 8 jusque la ligne 600
With Range("A" & Lg & ":A600").EntireRow
'On impose une hauteur de ligne suivant la valeur ds la cellule W3 de la feuille "ADMINISTRATEUR"
.RowHeight = Sheets("Administrateur").[W3].Value
'On centre verticalement les valeurs
.VerticalAlignment = xlCenter
'On centre Horizontalement les valeurs que sur la colonne A
.Columns("A:A").HorizontalAlignment = xlCenter
'On Impose une couleur de police
.Font.Color = RGB(0, 0, 0)
'On impose le texte en gras
.Font.Bold = True
End With
End Subet sur ce code:
'On Copie vers Tableau de Bord a partir de A8
.DataBodyRange.Copy [A8]n'autoriser que la valeur et non les formules.
Qu'en pensez-vous ?
Merci
A bientôt
Bonsoir le forum
Pas trouvé de solution, j’abandonne pour ce soir
Ma piste pour demain c’est de changer
DataBodyRange.Copy [A8]
A vous relire
Bonne soirée à tous
Bonsoir le forum
J'ai réussi à mettre un numéro de ligne merci pour le partage du code.
Dim datas, pl As Range, C As Range, c2 As Range, c3 As Range, i As Long, tmp
' 1 # INCREMENTER UN NUMERO DE LIGNE EN COL "A"
'On désactive les évènements
Application.EnableEvents = False
'Si erreur exécution -> instruction suivante ( Aucune SpecialCells )
On Error Resume Next
'
With ListObjects(1).Range.Columns(1)
For Each c3 In .SpecialCells(xlCellTypeBlanks)
c3 = Application.Max(.Cells) + 1
Next
End With
'On réactive les évènements
Application.EnableEvents = TrueMaintenant je souhaite que Si je modifie en col "M" de la feuille Tableau de bords" Alors recopie de la valeur en feuille "DataBase"
Merci pour votre aide
Bonne soirée à tous
bonsoir, dans la première partie du change-event, on cherche ce numéro dans l'autre feuille, on vérifie si les 12 cellules sont les mêmes (nécessaire ?) et puis on colle ...
Set C1 = Intersect(Target, Me.Columns("M")) 'toutes les cellules modifiées en colonne M
If Not C1 Is Nothing Then
For Each c2 In C1.Cells 'boucler
r = Application.Match(c2.Offset(, 1 - c2.Column).Value, Sheets("Database").Columns("A"), 0) 'rechercher ligne dans la feuille "database"
If IsNumeric(r) Then 'trouvé
s1 = WorksheetFunction.TextJoin("|", 0, c2.Offset(, 1 - c2.Column).Resize(, 12)) 'joindre les 12 cellules de "tableau de bord"
s2 = WorksheetFunction.TextJoin("|", 0, Sheets("Database").Cells(r, 1).Resize(, 12)) 'joindre les 12 cellules de "database"
If StrComp(s1, s2, 1) = 0 Then
Sheets("Database").Cells(r, 13).Value = c2.Value 's'ils sont egal, coller la valeur
Else
MsgBox "il y a une différence" & vbLf & s1 & vbLf & s2, vbExclamation 'avertissement
End If
Else
MsgBox "erreur copie colonne M", vbExclamation, c2.Offset(, 1 - c2.Column)
End If
Next
End IfBonsoir le forum
Bonsoir BsAlv
Merci pour ta proposition, je viens de l'essayer.
quand je fais une validation extraction, j'ai un bug , cela me bloque le PC, je suis obligé de faire fin de tache sur excel pour en sortir.
MsgBox "erreur copie colonne M", vbExclamation, c2.Offset(, 1 - c2.Column)J'ai donc essayé en mettant des points d'arrêt sur les lignes de ton code pour identifier la source.
et donc sur ton code:
Set C1 = Intersect(Target, Me.Columns("M")) 'toutes les cellules modifiées en colonne M
If Not C1 Is Nothing Then
For Each c2 In C1.Cells 'boucler
r = Application.Match(c2.Offset(, 1 - c2.Column).Value, Sheets("Database").Columns("A"), 0) 'rechercher ligne dans la feuille "database"
If IsNumeric(r) Then 'trouvé
s1 = WorksheetFunction.TextJoin("|", 0, c2.Offset(, 1 - c2.Column).Resize(, 12)) 'joindre les 12 cellules de "tableau de bord"
s2 = WorksheetFunction.TextJoin("|", 0, Sheets("Database").Cells(r, 1).Resize(, 12)) 'joindre les 12 cellules de "database"
If StrComp(s1, s2, 1) = 0 Then
Sheets("Database").Cells(r, 13).Value = c2.Value 's'ils sont egal, coller la valeur
' Else
' MsgBox "il y a une différence" & vbLf & s1 & vbLf & s2, vbExclamation 'avertissement
End If
'Else
' MsgBox "erreur copie colonne M", vbExclamation, c2.Offset(, 1 - c2.Column)
End If
Next
End Ifj'ai désactivé:
' Else
' MsgBox "il y a une différence" & vbLf & s1 & vbLf & s2, vbExclamation 'avertissement
End If
'Else
' MsgBox "erreur copie colonne M", vbExclamation, c2.Offset(, 1 - c2.Column)cela fonctionne mieux.
Je n'ai pas assez de temps pour aller plus loin ce soir.
Laisse moi stp essayer de le résoudre , et si je suis dans la mouise j'espère que tu suivras mon post pour m'aider
Merci
Bonne soiré à tous
Bonjour le forum
Bonjour BsAlv
voilà ce que j'ai fait:
Set C1 = Intersect(Target, Me.Columns("M")) 'toutes les cellules modifiées en colonne M
If Not C1 Is Nothing Then
For Each c2 In C1.Cells 'boucler
r = Application.Match(c2.Offset(, 1 - c2.Column).Value, Sheets("Database").Columns("A"), 0) 'rechercher ligne dans la feuille "database"
If IsNumeric(r) Then 'trouvé
s1 = WorksheetFunction.TextJoin("|", 0, c2.Offset(, 1 - c2.Column).Resize(, 12)) 'joindre les 12 cellules de "tableau de bord"
s2 = WorksheetFunction.TextJoin("|", 0, Sheets("Database").Cells(r, 1).Resize(, 12)) 'joindre les 12 cellules de "database"
'On fait une comparaison sur les 2 feuilles
If StrComp(s1, s2, 1) = 0 Then
'S'ils sont egal, coller la valeur
Sheets("Database").Cells(r, 13).Value = c2.Value
Else
MsgBox "il y a une différence" & vbLf & s1 & vbLf & s2, vbExclamation 'avertissement
End If
Else
If c2.Offset(, 1 - c2.Column).Value <> c2.Value Then
MsgBox "erreur copie colonne M", vbExclamation, c2.Offset(, 1 - c2.Column).Value <> c2.Value
Exit Sub
End If
End If
Next
End IfQu'en pensez-vous ?
A bientôt sur le forum
re,
c2 est la cellule ou une de ces cellules modifiée en colonne M.
c2.Offset(, 1 - c2.Column) est la cellule de la colonne A dans la même ligne et c'est le contenu de cette cellule qu'on rechercher dans la colonne A de la feuille "Database".
If c2.Offset(, 1 - c2.Column).value <> c2.value Then
MsgBox "erreur copie colonne M", vbExclamation, c2.Offset(, 1 - c2.Column).value <> c2.value
Exit Sub
End IfCela est l' "else" de l' "If IsNumeric(r) Then ...", donc on n'a pas trouvé une cellule en "Database". Qu'est-ce qu'on fait, on compare la cellule de la colonne A (numéro ligne) avec la cellule de la colonne M (état), à mon avis une comparaison inutile, qui finira toujours avec ce msgbox.
Re le forum
Re BsAlv, oui je suis d'accord avec toi pour supprimer ces lignes
Else
MsgBox "il y a une différence" & vbLf & s1 & vbLf & s2, vbExclamation 'avertissement
End If
Else
If c2.Offset(, 1 - c2.Column).Value <> c2.Value Then
MsgBox "erreur copie colonne M", vbExclamation, c2.Offset(, 1 - c2.Column).Value <> c2.Value
Exit Subj'ai continué mon fichier sans ces lignes de code, et tous fonctionne comme je le désire.
De toute façon:
1- Chaque nouvelles entrées dans DataBase à un numéro de ligne unique.
2 - avec ton code:
'On fait une comparaison sur les 2 feuilles
If StrComp(s1, s2, 1) = 0 Then
'S'ils sont egal, coller la valeur
Sheets("Database").Cells(r, 13).Value = c2.Valueje pense que cela est bien cerné
Merci de ta précieuse aide.
Bonne soirée à tous
Bonsoir le Forum
Bonsoir BsAlv
Merci pour ton aide, cela fonctionne comme je voulais
Je passe le post en résolu
A bientôt sur le forum