XL 2013 (Résolu par JOB) importation des données sauf les lignes avec cellules en GRAS

I

ibni

XLDnaute Nouveau
Bonjour à tous,
Je me permets de solliciter votre aide après avoir parcouru en long et en large mon ami Google ainsi que ce forum en vain.
En fait, je suis absolument nul et j'aimerais savoir est ce que c'est possible d'appliquer le code ci-dessous sur mon fichier joint pour importer toutes les données du fichier Matos vers Recap sans importer les lignes dont une cellule est en GRAS ( c'est à dire les lignes 8, 39,65,99,117,270,307,338,342,343,350,366,372,380,424,460,477,484,504,536,558,574,598,602)

VB: 
Private Sub CommandButton1_Click()
Dim t, nlig&, d As Object, i&, rest(), j&
Application.ScreenUpdating = False
With Workbooks.Open(ThisWorkbook.Path & "\Paie-Mens.xlsx").Sheets("Feuil1")
  t = .Range("A5:AC" & .Range("F" & .Rows.Count).End(xlUp).Row + 2)
  nlig = UBound(t)
  .Parent.Close False
End With
'---restitution du 1er tableau---
[E:E].Copy [AE1] 'sauvegarde la colonne E (matricules) en colonne auxiliaire AE
Range("A3:AC" & Rows.Count).ClearContents 'RAZ
[A3].Resize(nlig, 29) = t
'---liste des noms du 1er tableau---
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(t)
  If t(i, 5) <> "" Then d(t(i, 5)) = i 'repère la ligne
Next i
'---création du 2ème tableau (rest)---
t = Range("AD3:AE" & Range("AE" & Rows.Count).End(xlUp).Row + 1)
ReDim rest(1 To nlig, 1 To 1)
For i = 1 To UBound(t)
  If t(i, 2) <> "" And d.Exists(t(i, 2)) Then rest(d(t(i, 2)), 1) = t(i, 1)
Next i
'---restitution du 2ème tableau (rest)---
[[URL='http://ae:af].delete/']AE:AF].Delete[/URL] 'à l'origine il y avait des formules en colonne AF
Range("AD3:AD" & Rows.Count).ClearContents 'RAZ
[AD3].Resize(nlig) = rest
End Sub


Merci pour votre aide
 

Pièces jointes

  • MATOS.xlsx
    63 KB · Affichages: 100
  • RECAP.xlsx
    39.6 KB · Affichages: 95
Trier par date Trier par votes
Staple1600

Staple1600

XLDnaute Barbatruc
Bonsoir à tous

Une possibilité (en passant d'abord par la copie de la feuille)
CTRL+H -> Options -> Format -> Police -> Gras
Remplacer par -> Format -> Remplissage -> choisir une couleur qui n'est pas utilisée sur la feuille
-> Remplacer tout
Ensuite filtre automatique -> Filtrer par couleur
Clic-droit -> Supprimer lignes
Ci-dessous ces étapes en VBA (jusqu'au filtrage par couleur)
VB: 
Sub a()
With Application.ReplaceFormat.Interior
       .PatternColorIndex = xlAutomatic
       .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
End With
Selection.Replace What:="", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, SearchFormat:=True, ReplaceFormat:=True
Range("A8:K601").AutoFilter Field:=1, Criteria1:=RGB(252, 228, 214), Operator:=xlFilterCellColor
End Sub

EDITION: Bonsoir job75
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonsoir ibni, Jean-Marie,
Une solution qui pourra fonctionner sur toute version Excel :
Code: 
Function Gras(c As Range) As Boolean
Gras = c.Font.Bold
End Function

Sub Importer()
Dim F As Worksheet, derlig&
Set F = Feuil1 'CodeName de la feuille de destination
Application.ScreenUpdating = False
F.Range("A8:L" & F.Rows.Count).Delete xlUp 'RAZ
With Workbooks.Open(ThisWorkbook.Path & "\MATOS.xlsx").Sheets(1) 'feuille source
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    derlig = .Cells(.Rows.Count, 1).End(xlUp).Row
    If derlig >= 8 Then .Range("A8:L" & derlig).Copy F.[A8]
    .Parent.Close False
    If derlig < 8 Then Exit Sub
End With
With F.Range("L8:L" & derlig)
    .FormulaR1C1 = "=1/Gras(RC1)" 'utilise la fonction
    On Error Resume Next 's'il n'y a pas de police "gras"
    .SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete
    .Value = ""
End With
With F.UsedRange: End With 'actualise la barre de défilement verticale
End Sub
Les 2 fichiers joints sont à placer dans le même répertoire (le bureau).

Bonne fin de soirée.
 

Pièces jointes

  • RECAP(1).xlsm
    47.3 KB · Affichages: 100
  • MATOS.xlsx
    61.9 KB · Affichages: 88
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re,

Je n'avais pas fait attention : dans MATOS les cellules A380, A424, A536 ont les 1ers caractères gras et les derniers non gras.

Pour pouvoir supprimer ces 3 lignes dans RECAP il faut modifier la fonction :
Code: 
Function Gras(c As Range) As Boolean
Gras = c.Characters(1, 1).Font.Bold
End Function
J'en profite pour préciser que cette fonction doit impérativement être dans un module standard (Module1).

Fichier (2).

Bonne nuit.
 

Pièces jointes

  • RECAP(2).xlsm
    49.1 KB · Affichages: 102
  • MATOS.xlsx
    61.9 KB · Affichages: 90
Vote positif 0 Vote négatif
I

ibni

XLDnaute Nouveau
Bonsoir Job, Staple,
merci beaucoup Job vous avez vraiment compris & répondu sur ma demande comme il faut
c'est exactement ce que je souhaitais avoir, même si votre code me paraît comme du chinois
j'ai une petite question de débutant a vous posez :
j'ai rajouté une colonne L dans le classeur recap ou j'ai inséré manuellement les codes qui définit chaque matériel, donc quand je rajoute des lignes dans le fichier matos et en faisant l'importation sur RECAP je perds tout les codes et la ligne L se vide

Bonne fin de soirée
 

Pièces jointes

  • RECAP.xlsm
    73.1 KB · Affichages: 93
  • MATOS.xlsx
    59.6 KB · Affichages: 96
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour ibni, le forum,

Si les éléments (non gras) de la colonne A ne sont pas toujours les mêmes dans les 2 fichiers il n'est pas possible de faire un lien entre la colonne L du fichier RECAP et le fichier MATOS, donc cette colonne L doit être supprimée.

Si par contre les éléments sont identiques, il suffit de ne pas toucher à la colonne L et d'insérer une colonne auxiliaire devant.

Maintenant voici une amélioration très importante.

La suppression de lignes disjointes dans un grand tableau peut prendre beaucoup de temps, pour accélérer il faut ajouter un tri :
Code: 
Function Gras(c As Range) As Boolean
Gras = c.Characters(1, 1).Font.Bold
End Function

Sub Importer()
Dim t#, F As Worksheet, derlig&
t = Timer
Set F = Feuil1 'CodeName de la feuille de destination
Application.ScreenUpdating = False
F.Range("A8:K" & F.Rows.Count).Delete xlUp 'RAZ
With Workbooks.Open(ThisWorkbook.Path & "\MATOS.xlsx").Sheets(1) 'feuille source
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    derlig = .Cells(.Rows.Count, 1).End(xlUp).Row
    If derlig >= 8 Then .Range("A8:K" & derlig).Copy F.[A8]
    .Parent.Close False
    If derlig < 8 Then Exit Sub
End With
F.[L:L].Insert 'insertion d'une colonne auxiliaire devant la colonne L
With F.Range("L8:L" & derlig)
    .FormulaR1C1 = "=1/Gras(RC1)" 'utilise la fonction
    .Value = .Value 'supprime les formules
    F.Range("A8", .Cells).Sort .Cells, xlDescending, Header:=xlNo 'tri pour accélérer, les "1" sont en bas
    derlig = derlig - Application.Count(.Cells)
    On Error Resume Next 's'il n'y a pas de police "gras"
    Intersect(.SpecialCells(xlCellTypeConstants, 1).EntireRow, F.[A:L]).Delete xlUp
End With
F.[L:L].Delete 'suppression de la colonne auxiliaire
F.Range("B8:L" & derlig).Borders.Weight = xlThin 'bordures
F.Rows(derlig + 1 & ":" & F.Rows.Count).Delete 'RAZ en dessous du tableau
With F.UsedRange: End With 'actualise la barre de défilement verticale
Application.ScreenUpdating = True
MsgBox "Durée " & Format(Timer - t, "0.00 \s"), , "Importation"
End Sub
Fichier (3).

A+
 

Pièces jointes

  • RECAP(3).xlsm
    51 KB · Affichages: 96
  • MATOS.xlsx
    59.6 KB · Affichages: 92
Dernière édition:
Vote positif 0 Vote négatif
I

ibni

XLDnaute Nouveau
re Job,
après avoir testé le dernier fichier j'ai remarqué que quand j'ajoute une ligne d'un nouveau matériel dans Matos et après importation dans RECAP, les codes de la colonne L ne se décale pas du coup la ligne que j'ai ajouté prend le code d'une autre ligne alors qu'elle doit être vide pour que j'insére manuellement le code
 

Pièces jointes

  • MATOS.xlsx
    59.9 KB · Affichages: 96
  • RECAP(3).xlsm
    80.2 KB · Affichages: 94
Vote positif 0 Vote négatif
I

ibni

XLDnaute Nouveau
re,
les fichiers auront toujours les mêmes données mais de temps en temps j'aurais des nouvelles lignes qui s'ajoutent et d'autres qui s'effacent.
donc chaque ligne ajouté dans matos après importation la cellule correspondante dans la colonne L doit être vide pour que j'insére le code et chaque ligne supprimé dans Matos s'effacera avec son code correspondant après actualisation dans RECAP

A+
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re,

Comme l'ami an@s vous avez du mal à comprendre .

Aucune donnée ajoutée en colonne L, M ou autre dans RECAP ne suivra les données importées de MATOS puisque les 2 tableaux n'ont aucun lien entre eux.

Je n'avais pas actualisé la barre de défilement verticale dans le fichier (3), je le corrige même s'il ne vous satisfait pas.

A+
 
Vote positif 0 Vote négatif
I

ibni

XLDnaute Nouveau
re,
dans le fichier de l'autre utilisateur ce code que vous avez mis dans le poste 12 à bien marché chez lui comme il a confirmé et que j'ai testé aussi avant de créer cette discussion.. et dans AE il avait des imputations qu'il n'avait pas dans le tableau d'origine et à chaque fois tu rajoute une ligne dans le tableau d'origine il s'ajoute automatiquement dans le tableau de destination et les cellules de la colonne AE se decale et celle de la ligne ajouté reste vide pour l'insérer manuellement..
j'ai essayé d'appliqué la même chose mais je suis nul dans VBA

VB: 
Private Sub CommandButton1_Click()
Dim t, nlig&, d As Object, i&, rest(), j&
Application.ScreenUpdating = False
With Workbooks.Open(ThisWorkbook.Path & "\Paie-Mens.xlsx").Sheets("Feuil1")
  t = .Range("A5:AC" & .Range("F" & .Rows.Count).End(xlUp).Row + 2)
  nlig = UBound(t)
  .Parent.Close False
End With
'---restitution du 1er tableau---
[E:E].Copy [AE1] 'sauvegarde la colonne E (matricules) en colonne auxiliaire AE
Range("A3:AC" & Rows.Count).ClearContents 'RAZ
[A3].Resize(nlig, 29) = t
'---liste des noms du 1er tableau---
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(t)
  If t(i, 5) <> "" Then d(t(i, 5)) = i 'repère la ligne
Next i
'---création du 2ème tableau (rest)---
t = Range("AD3:AE" & Range("AE" & Rows.Count).End(xlUp).Row + 1)
ReDim rest(1 To nlig, 1 To 1)
For i = 1 To UBound(t)
  If t(i, 2) <> "" And d.Exists(t(i, 2)) Then rest(d(t(i, 2)), 1) = t(i, 1)
Next i
'---restitution du 2ème tableau (rest)---
[[URL='http://ae:af].delete/']AE:AF].Delete[/URL] 'à l'origine il y avait des formules en colonne AF
Range("AD3:AD" & Rows.Count).ClearContents 'RAZ
[AD3].Resize(nlig) = rest
End Sub
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re,

Sur le fil d'an@s on faisait autre chose : les lignes qui avait les mêmes références étaient conservées, et ces références devaient être sans doublon.

Vos 2 fichiers n'ont pas une colonne de références sans doublon.

A+
 
Vote positif 0 Vote négatif

Discussions similaires

halecs93
  • Résolu(e)
XL 2016 Indice n'appartient pas à la sélection : HELP !!!!
2
Réponses
21
Affichages
999
halecs93
halecs93
N
  • Question
XL 2019 Mettre en gras éléments du graphique avec macro
Réponses
4
Affichages
599
Nasseuz
N
S
  • Question
XL 2016 Problème dans la création d'une liste
Réponses
2
Affichages
276
Stéphane_1
S
L
  • Résolu(e)
Microsoft 365 Suppression de cellules vide
Réponses
3
Affichages
370
Le Rouky
L
A
  • Question
Microsoft 365 Code VBA Envoi contenu tableau Excel par Email
Réponses
1
Affichages
312
Phil69970
Phil69970
D
  • Question
envois automatique d'email avec EXCEL et une MACRO
Réponses
4
Affichages
694
AtTheOne
AtTheOne
Nicolas JACQUIN
  • Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
848
Nicolas JACQUIN
Nicolas JACQUIN
B
  • Question
Microsoft 365 Additionner des cellules même ligne en userform vba
Réponses
13
Affichages
575
sousou
sousou
I
  • Question
Microsoft 365 SOMMEPROD en vba excel
Réponses
12
Affichages
424
iliess
I
M
  • Question
XL 2019 Optimisation de code VBA
2 3
Réponses
33
Affichages
2 K
mmaiga
M

Membres actuellement en ligne

21 membres et 267 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 486
Messages
2 110 114
Membres
110 670
dernier inscrit
Mangouste