Mise à jour des imputations (Résolue par Job)

an@s

XLDnaute Occasionnel
Bonjour à tous,

dans le fichier ci-joint j'ai un code qui m'a fourni job qui permet de faire l'importation des données d'un autre fichier sauf les cellules qui sont en gras.
après importation le code rajoute des nouvelles lignes dont L est vide, donc les cellules de la colonne L je dois les remplir manuellement.
ce que je souhaite faire c'est créer un autre code qui permet de faire cela :

si j'ai plusieurs données dans la colonne A qui sont les mêmes et une données ou plusieurs de la colonne A ont déjà la colonne L remplie, donc il faut copier cette donnée dans les autres cellules vides de la colonne L

exemple :
A9= A10, A11, A12, A13 puis L9 est déjà remplie dont il faut copier L9 dans L10, L11, L12, L13 et la couleur de remplissage de L10, L11, L12, L13 soit jaune

Merci beaucoup pour votre assistance

Cordialement
An@s
 

Fichiers joints

job75

XLDnaute Barbatruc
Bonjour an@s,
Code:
Sub MAJ_Imputation()
Dim ncol%
Application.ScreenUpdating = False
With Feuil01.[A7].CurrentRegion.Offset(1)
  ncol = .Columns.Count
  .Cells(1, ncol + 1) = 1
  .Columns(ncol + 1).DataSeries 'ordre initial numéroté
  .Resize(, ncol + 1).Sort .Columns(1), , .Columns(ncol), Header:=xlNo 'tri sur 2 colonnes
  .Columns(ncol).SpecialCells(xlCellTypeBlanks) = "=REPT(R[-1]C,R[-1]C1=RC1)"
  .Columns(ncol) = .Columns(ncol).Value 'supprimme les formules
  .Resize(, ncol + 1).Sort .Columns(ncol + 1), xlAscending, Header:=xlNo 'remise en ordre initial
  .Cells(1, ncol).Resize(Rows.Count - .Row).Interior.ColorIndex = xlNone 'RAZ couleur
  .Columns(ncol + 1) = "=1/(COUNTIF(C[-1],RC[-1])>1)"
  On Error Resume Next 's'il n'y a pas de SpecialCells
  Intersect(.Columns(ncol), .Columns(ncol + 1).SpecialCells(xlCellTypeFormulas, 1).EntireRow).Interior.ColorIndex = 6 'jaune
  .Columns(ncol + 1) = "" 'RAZ de la colonne auxiliaire
End With
End Sub
PS : la macro Importer je l'ai faite en octobre 2016 pour une dénommée ibni déclarée du sexe féminin.

Mais compte tenu de vos nombreux pseudos an@s vous n'en êtes pas à un sexe près n'est-ce pas :rolleyes:

A+
 

job75

XLDnaute Barbatruc
Re,

J'ai testé la macro précédente sur un tableau de 2800 lignes : la formule avec COUNTIF (NB.SI) pour la mise en couleur prend beaucoup trop de temps.

J'ai donc modifié la formule avec une 2ème colonne auxiliaire (et le tri à la fin) :
Code:
Sub MAJ_Imputation()
Dim ncol%
Application.ScreenUpdating = False
With Feuil01.[A7].CurrentRegion.Offset(1)
  ncol = .Columns.Count
  .Cells(1, ncol + 1) = 1
  .Columns(ncol + 1).DataSeries 'ordre initial numéroté
  .Resize(, ncol + 1).Sort .Columns(1), , .Columns(ncol), Header:=xlNo 'tri sur 2 colonnes
  .Columns(ncol).SpecialCells(xlCellTypeBlanks) = "=REPT(R[-1]C,R[-1]C1=RC1)"
  .Columns(ncol) = .Columns(ncol).Value 'supprimme les formules
  .Cells(1, ncol).Resize(Rows.Count - .Row).Interior.ColorIndex = xlNone 'RAZ couleur
  .Columns(ncol + 2) = "=1/(RC[-2]<>"""")/OR(RC[-2]=R[1]C[-2],RC[-2]=R[-1]C[-2])"
  On Error Resume Next 's'il n'y a pas de SpecialCells
  Intersect(.Columns(ncol), .Columns(ncol + 2).SpecialCells(xlCellTypeFormulas, 1).EntireRow).Interior.ColorIndex = 6 'jaune
  .Resize(, ncol + 1).Sort .Columns(ncol + 1), xlAscending, Header:=xlNo 'remise en ordre initial
  .Columns(ncol + 1).Resize(, 2) = "" 'RAZ des 2 colonnes auxiliaires
End With
End Sub
C'est maintenant très rapide.

A+
 

an@s

XLDnaute Occasionnel
Bonsoir Job, leforum
pour ce qui concerne les psoeudos je m'excuse encore une autre fois mais j'ai déjà donné une promesse de ne plus me connecter qu'avec celui-ci

pour votre réponse c'est exactement ce que je souhaitais surtout le 2ème code il est plus rapide mais il y'a une petite modification à faire :
  • pour les couleurs il ne faut pas colorer la première cellule de la colonne L qui existait déjà, les cellules qui doivent prendre la couleur jaune c'est celles qui sont copiées.(comme dans le fichier ci-joint)
  • dans le cas ou on plusieurs cellules de la colonne A qui sont les mêmes et dans la colonne L on a deux ou trois qui existe déjà il faut copier juste la premier pour les autres qui sont vide, exemple : A30, A31, A32,A33, A34 sont les mêmes et L31 et L32 sont déjà remplies mais différements donc il faut prendre L31 et la copier dans L32, L33, L34 et colorer ces 3 cellules en jaune.

Merci beaucoup pour tout Job et je m'excuse encore 1000 fois pour le trucs des pseudos si mes excuses que j'ai faite avant ne sont pas suffisantes

Amicalement
An@s
 

Fichiers joints

job75

XLDnaute Barbatruc
Re,

Désolé, c'est trop compliqué, ceci sera ma dernière macro sur ce fil :
Code:
Sub MAJ_Imputation()
Dim ncol%
Application.ScreenUpdating = False
With Feuil01.[A7].CurrentRegion.Offset(1)
  ncol = .Columns.Count
  .Cells(1, ncol + 1) = 1
  .Columns(ncol + 1).DataSeries 'ordre initial numéroté
  .Resize(, ncol + 1).Sort .Columns(1), , .Columns(ncol), Header:=xlNo 'tri sur 2 colonnes
  .Columns(ncol).SpecialCells(xlCellTypeBlanks) = "=REPT(R[-1]C,R[-1]C1=RC1)"
  .Columns(ncol) = .Columns(ncol).Value 'supprime les formules
  .Columns(ncol).Interior.ColorIndex = xlNone 'RAZ couleur
  .Columns(ncol + 2) = "=1/(RC[-2]<>"""")/(RC[-2]=R[-1]C[-2])"
  On Error Resume Next 's'il n'y a pas de SpecialCells
  Intersect(.Columns(ncol), .Columns(ncol + 2).SpecialCells(xlCellTypeFormulas, 1).EntireRow).Interior.ColorIndex = 6 'jaune
  .Resize(, ncol + 1).Sort .Columns(ncol + 1), xlAscending, Header:=xlNo 'remise en ordre initial
  .Columns(ncol + 1).Resize(, 2) = "" 'RAZ des 2 colonnes auxiliaires
End With
End Sub
Notez que dans mes 2 macros précédentes la RAZ couleur créait des fichiers de 5,5 Mo !!!

A+
 

an@s

XLDnaute Occasionnel
Re,
la dérnière réponse correspond parfaitement à ce que je souhaite le seul souci comme vous avez dit c'est la taille du fichier.
mais comme vous dites que c'est compliqué je laisse tomber parce que avec un fichier de plus de 1500 lignes cela rend le classeur plus lourd

en tout cas merci beaucoup Job pour vos réponses

Amicalement
An@s
 

an@s

XLDnaute Occasionnel
Oups,
désolé je viens de refaire le test et je confirme que le problème de taille est corrigé
de plus la 2ème demande de mon poste 4 est résolu aussi alors que vous me dites le contraire,
regardez bien A24, A25, A26, A27, A28 sont les mêmes par contre L24, L26, L27 sont différentes et une fois je clique sur mise à jour le code remplit L25 et L28 par la données de L24 c'est à dire la première et c'est ce que je voulais....
c'est pas ce que vous avez compris dans mon 4ème post ou ça c'est fait automatiquement dans votre code sans que vous le sachiez ???

Amicalement
An@s
 

Fichiers joints

an@s

XLDnaute Occasionnel
Re,
désolé si je me suis mal exprimé...
vous avez bien répondu sur mais demandes, le seul souci qui reste c'est que le code colore toutes les cellules en doublons dans la colonne L sauf la première même celles qui existait déjà alors que moi je veux qu'il colore juste celles qui étaient vide avant la mise à jour et non celles qui existaient déjà même si elles sont en doublon.

exemple dans le fichier ci-joint:
A9=A10=A11=A12=13 puis L9 et L10 comportent les mêmes données et L11, L12, L13 sont vide :
le code copie bien les données de L9 dans L11, L12, L13 et colore L10,L11, L12, L13 en jaune alors qu'il doit colorer juste les cellules qui était vide avant mise à jour, il ne doit pas colorer L10 qui existait déjà avant mise à jour

Cordialement
An@s
 

Fichiers joints

Dernière édition:

job75

XLDnaute Barbatruc
Bonjour an@s, le forum,
alors que moi je veux qu'il colore juste celles qui étaient vide avant la mise à jour et non celles qui existaient déjà même si elles sont en doublon.
C'est bien ce que j'avais compris et c'est pour ça que je disais que c'était compliqué !

Mais on s'en sort en utilisant 3 colonnes auxiliaires :
Code:
Sub MAJ_Imputation()
Dim ncol%, P As Range
Application.ScreenUpdating = False
With Feuil01.[A7].CurrentRegion.Offset(1)
  ncol = .Columns.Count
  .Cells(1, ncol + 1) = 1
  .Columns(ncol + 1).DataSeries '1ère colonne auxiliaire, ordre initial numéroté
  .Resize(, ncol + 1).Sort .Columns(1), , .Columns(ncol), Header:=xlNo 'tri sur 2 colonnes
  Set P = .Columns(ncol).SpecialCells(xlCellTypeBlanks)
  P = "=REPT(R[-1]C,R[-1]C1=RC1)"
  .Columns(ncol) = .Columns(ncol).Value 'supprime les formules
  .Columns(ncol + 2) = "" 'sécurité
  Intersect(P.EntireRow, .Columns(ncol + 2)) = 1 '2ème colonne auxiliaire
  .Columns(ncol + 3) = "=1/(RC[-1]=1)/(RC[-3]<>"""")/(RC[-3]=R[-1]C[-3])" '3ème colonne auxiliaire
  On Error Resume Next 's'il n'y a pas de SpecialCells
  Intersect(.Columns(ncol), .Columns(ncol + 3).SpecialCells(xlCellTypeFormulas, 1).EntireRow).Interior.ColorIndex = 6 'jaune
  .Resize(, ncol + 1).Sort .Columns(ncol + 1), xlAscending, Header:=xlNo 'remise en ordre initial
  .Columns(ncol + 1).Resize(, 3) = "" 'RAZ des 3 colonnes auxiliaires
End With
End Sub
Je ne fais plus de RAZ couleur car les couleurs seraient effacées si l'on relançait la macro.

Mais je me demande à quoi peut bien servir cette mise en couleur !

Bonne journée.
 

Fichiers joints

an@s

XLDnaute Occasionnel
Bonjour Job,

merci infiniment pour la rectification, c'est exactement ce que je voulais comme résultat
je sais que je vous tracasse la tête avec mes demandes mais j'ai juste besoin d'une petite modification importante avant de clôturer ce fil afin d'avoir un résultat complet si c'est possible biensur.

comme vous pouvez constater dans le fichier ci-joint :
A9=A10=A11=A12=A13=A14=A15 puis L9 et L10 sont différents dans ce cas le code doit copier la première valeur c'est à dire L9 dans L11, L12; L13, L14, L15 au lieu de copier la plus grande.

parce que le code copie la valeur plus grande et dans ce cas il copie L10 parce qu'elle plus grande que L9 et si on met dans L9 par exemple BOX.SS.TF.30 c'est cette valeur qui va copier

cordialement
An@s
 

Fichiers joints

job75

XLDnaute Barbatruc
Re,
dans ce cas le code doit copier la première valeur c'est à dire L9 dans L11, L12; L13, L14, L15 au lieu de copier la plus grande.
Cela change pas mal de choses :
Code:
Sub MAJ_Imputation()
Dim ncol%
Application.ScreenUpdating = False
On Error Resume Next 's'il n'y a pas de SpecialCells
With Feuil01.[A7].CurrentRegion
  With .Offset(1).Resize(.Rows.Count - 1)
    ncol = .Columns.Count
    .Cells(1, ncol + 1) = 1
    .Columns(ncol + 1).DataSeries '1ère colonne auxiliaire, ordre initial numéroté
    .Columns(ncol + 2) = 0
    Intersect(.Columns(ncol).SpecialCells(xlCellTypeBlanks).EntireRow, .Columns(ncol + 2)) = 1 '2ème colonne auxiliaire
    .Resize(, ncol + 2).Sort .Columns(ncol + 2), xlAscending, Header:=xlNo 'tri sur la 2ème colonne auxiliaire
    .Columns(ncol).SpecialCells(xlCellTypeBlanks) = "=IF(ROW()=MATCH(RC1,C1,0),"""",INDEX(C,MATCH(RC1,C1,0)))" 'copie la 1ère occurence
    .Columns(ncol) = .Columns(ncol).Value 'supprime les formules
    .Columns(ncol + 3) = "=1/(RC[-1]=1)/(RC[-3]<>"""")" '3ème colonne auxiliaire
    Intersect(.Columns(ncol), .Columns(ncol + 3).SpecialCells(xlCellTypeFormulas, 1).EntireRow).Interior.ColorIndex = 6 'jaune
    .Resize(, ncol + 1).Sort .Columns(ncol + 1), xlAscending, Header:=xlNo 'remise en ordre initial
    .Columns(ncol + 1).Resize(, 3) = "" 'RAZ des 3 colonnes auxiliaires
  End With
End With
End Sub
A+
 

Fichiers joints

an@s

XLDnaute Occasionnel
Re,
Merci beaucoup Job le code maintenant est complet...
je vous souhaite un bon weekend

Amicalement
An@s
 

job75

XLDnaute Barbatruc
Re,

Bah 2 colonnes auxiliaires suffisent puisque le tri regroupe les cellules vides :
Code:
Sub MAJ_Imputation()
Dim ncol%
Application.ScreenUpdating = False
On Error Resume Next 's'il n'y a pas de SpecialCells
With Feuil01.[A7].CurrentRegion
  With .Offset(1).Resize(.Rows.Count - 1)
    ncol = .Columns.Count
    .Cells(1, ncol + 1) = 1
    .Columns(ncol + 1).DataSeries '1ère colonne auxiliaire, ordre initial numéroté
    .Columns(ncol + 2) = 0
    Intersect(.Columns(ncol).SpecialCells(xlCellTypeBlanks).EntireRow, .Columns(ncol + 2)) = 1 '2ème colonne auxiliaire
    .Resize(, ncol + 2).Sort .Columns(ncol + 2), xlAscending, Header:=xlNo 'tri sur la 2ème colonne auxiliaire
    With .Columns(ncol).SpecialCells(xlCellTypeBlanks) 'cellules vides regroupées en bas de la colonne par le tri
      .FormulaR1C1 = "=IF(ROW()=MATCH(RC1,C1,0),"""",INDEX(C,MATCH(RC1,C1,0)))" 'copie la 1ère occurence
      .Value = .Value 'supprime les formules
      .SpecialCells(xlCellTypeConstants).Interior.ColorIndex = 6 'jaune
    End With
    .Resize(, ncol + 1).Sort .Columns(ncol + 1), xlAscending, Header:=xlNo 'remise en ordre initial
    .Columns(ncol + 1).Resize(, 2) = "" 'RAZ des 2 colonnes auxiliaires
  End With
End With
End Sub
On y arrive enfin, c'est bien sûr un peu plus rapide.

A+
 

Fichiers joints

an@s

XLDnaute Occasionnel
Merci beaucoup Job pour la modification,
vous êtes vraiment parfait dans vos réponses, vous ne laissez jamais mêmes les petits détails...
une petite question si vous permettez; dans le cas ou la colonne A était E qu'est ce qu'il faut changer ??

je vous remercie encore une autre fois

Amicalement
An@s
 

job75

XLDnaute Barbatruc
Re,
dans le cas ou la colonne A était E qu'est ce qu'il faut changer ??
Il y aurait juste la formule à modifier pour qu'elle traite la 5ème colonne de la feuille :

.FormulaR1C1 = "=IF(ROW()=MATCH(RC5,C5,0),"""",INDEX(C,MATCH(RC5,C5,0)))"

A+
 

an@s

XLDnaute Occasionnel
Re,
nickel merci infiniment Mr Job pour le code, les modifications aussi bien d'avoir accepté de vous tracasser la tête avec mes demandes.

Cordialement
An@s
 

job75

XLDnaute Barbatruc
Bonjour an@s, le forum,

2 compléments qui peuvent être intéressants avec ce fichier (5) :

- affichage des données si la feuille est filtrée

- RAZ préalable des cellules colorées.
Code:
Function Couleur(c As Range)
Couleur = IIf(c.Interior.ColorIndex = xlNone, "", 1)
End Function

Sub MAJ_Imputation()
Dim ncol%
Application.ScreenUpdating = False
On Error Resume Next 's'il n'y a pas de SpecialCells
With Feuil01.[A7].CurrentRegion
  .Parent.ShowAllData 'si la feuille est filtrée
  With .Offset(1).Resize(.Rows.Count - 1)
    ncol = .Columns.Count
    .Columns(ncol + 1) = "=Couleur(RC[-1])" '1ère colonne auxiliaire
    Intersect(.Columns(ncol), Columns(ncol + 1).SpecialCells(xlCellTypeFormulas, 1).EntireRow) = "" 'RAZ des cellules colorées
    .Columns(ncol).Interior.ColorIndex = xlNone 'RAZ couleur
    .Cells(1, ncol + 1) = 1
    .Columns(ncol + 1).DataSeries '1ère colonne auxiliaire, ordre initial numéroté
    .Columns(ncol + 2) = 0
    Intersect(.Columns(ncol).SpecialCells(xlCellTypeBlanks).EntireRow, .Columns(ncol + 2)) = 1 '2ème colonne auxiliaire
    .Resize(, ncol + 2).Sort .Columns(ncol + 2), xlAscending, Header:=xlNo 'tri sur la 2ème colonne auxiliaire
    With .Columns(ncol).SpecialCells(xlCellTypeBlanks) 'cellules vides regroupées en bas de la colonne par le tri
      .FormulaR1C1 = "=IF(ROW()=MATCH(RC1,C1,0),"""",INDEX(C,MATCH(RC1,C1,0)))" 'copie la 1ère occurence
      .Value = .Value 'supprime les formules
      .SpecialCells(xlCellTypeConstants).Interior.ColorIndex = 6 'jaune
    End With
    .Resize(, ncol + 1).Sort .Columns(ncol + 1), xlAscending, Header:=xlNo 'remise en ordre initial
    .Columns(ncol + 1).Resize(, 2) = "" 'RAZ des 2 colonnes auxiliaires
  End With
End With
End Sub
Testé sur 30 000 lignes, on passe de 1 à 2 secondes en durée d'exécution, c'est donc acceptable.

Bonne journée.
 

Fichiers joints

an@s

XLDnaute Occasionnel
bonjour job, le forum
merci beaucoup pour la modification... c'est parfait

amicalement
an@s
 

Discussions similaires


Haut Bas