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
job75

job75

XLDnaute Barbatruc
Bonjour ibni, le forum,

Dans ce fichier (4) j'utilise comme références sans doublon les concaténations de toutes les cellules de A à K de chaque ligne :
Code: 
Function Gras(c As Range) As Boolean
Gras = c.Characters(1, 1).Font.Bold
End Function

Sub Importer()
Dim t#, F As Worksheet, d As Object, derlig1&, tablo, i&, x$, j%, derlig&, code, coderest()
t = Timer
Set F = Feuil1 'CodeName de la feuille de destination
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
'---liste sans doublon des concaténations de A à K---
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
derlig1 = F.Cells(F.Rows.Count, 1).End(xlUp).Row
If derlig1 > 7 Then
    tablo = F.Range("A8:K" & derlig1) 'matrice, plus rapide
    For i = 1 To UBound(tablo)
        x = ""
        For j = 1 To 11 'A à K
          x = x & "#" & tablo(i, j)
        Next j
        If x <> "" Then d(x) = i 'repérage de la ligne
    Next i
End If
F.Range("A8:K" & F.Rows.Count).Delete xlUp 'RAZ
'---copie du tableau source---
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 > 7 Then .Range("A8:K" & derlig).Copy F.[A8]
    .Parent.Close False
    If derlig < 8 Then derlig = 7: GoTo 1
End With
'---suppression des lignes en gras---
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
'---repositionnement des codes colonne L---
If derlig1 > 7 And derlig > 7 Then
    tablo = F.Range("A8:K" & derlig)
    code = F.Range("L8:M" & derlig1) 'au moins 2 éléments
    ReDim coderest(1 To derlig, 1 To 1)
    For i = 1 To UBound(tablo)
        x = ""
        For j = 1 To 11 'A à K
          x = x & "#" & tablo(i, j)
        Next j
        If d.exists(x) Then coderest(i, 1) = code(d(x), 1)
    Next i
    F.Range("L8:L" & derlig) = coderest
End If
'---finale---
F.Range("B8:L" & derlig).Borders.Weight = xlThin 'bordures
1 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
Chaque code en colonne L est restitué s'il n'y a eu aucune modification de sa ligne.

A+
 

Pièces jointes

  • RECAP(4).xlsm
    72.5 KB · Affichages: 88
  • MATOS.xlsx
    59.8 KB · Affichages: 91
Dernière édition:
Vote positif 0 Vote négatif
I

ibni

XLDnaute Nouveau
Bonjour Job,
merci beaucoup pour ce travail je ne sais pas vraiment si ça vous a pris du temps pour le réaliser pour quelqu'un qui ne connait rien en VBA c'est enorme..
est ce qu'on pourrait exclure les colonnes I, J, K vu que les montants de ces colonnes changent régulièrement

Merci d'avance
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re,

On peut même restituer les couleurs en colonne L s'il y en a :
Code: 
Function Gras(c As Range) As Boolean
Gras = c.Characters(1, 1).Font.Bold
End Function

Sub Importer()
Dim t#, F As Worksheet, d As Object, derlig1&, tablo, i&, x$, j&, derlig&
Dim P As Range, code, coderest(), flag As Boolean
t = Timer
Set F = Feuil1 'CodeName de la feuille de destination
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
'---liste sans doublon des concaténations de A à H---
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
derlig1 = F.Cells(F.Rows.Count, 1).End(xlUp).Row
If derlig1 > 7 Then
    tablo = F.Range("A8:H" & derlig1) 'matrice, plus rapide
    For i = 1 To UBound(tablo)
        x = ""
        For j = 1 To 8 'A à H
            x = x & "#" & tablo(i, j)
        Next j
        If x <> "" Then d(x) = i 'repérage de la ligne
    Next i
End If
F.Range("A8:K" & F.Rows.Count).Delete xlUp 'RAZ
'---copie du tableau source---
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 > 7 Then .Range("A8:K" & derlig).Copy F.[A8]
    .Parent.Close False
    If derlig < 8 Then derlig = 7: GoTo 1
End With
'---suppression des lignes en gras---
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
'---repositionnement des codes colonne L---
If derlig1 > 7 And derlig > 7 Then
    tablo = F.Range("A8:H" & derlig)
    Set P = F.Range("L8:L" & derlig1)
    code = P.Resize(, 2) 'au moins 2 éléments
    ReDim coderest(1 To derlig, 1 To 2)
    For i = 1 To UBound(tablo)
        x = ""
        For j = 1 To 8 'A à H
            x = x & "#" & tablo(i, j)
        Next j
        If d.exists(x) Then
            j = d(x)
            coderest(i, 1) = code(j, 1)
            If P(j).Interior.ColorIndex <> xlNone Then coderest(i, 2) = P(j).Interior.Color: flag = True
        End If
    Next i
    F.Range("L8:L" & derlig) = coderest
    '---restitution des couleurs colonne L---
    If flag Then
        P.Interior.ColorIndex = xlNone 'RAZ des couleurs
        For i = 1 To UBound(tablo)
            If coderest(i, 2) <> "" Then P(i).Interior.Color = coderest(i, 2)
        Next i
    End If
End If
'---finale---
F.Range("B8:L" & derlig).Borders.Weight = xlThin 'bordures
1 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 (5 bis).
 

Pièces jointes

  • RECAP(5 bis).xlsm
    70.3 KB · Affichages: 60
  • MATOS.xlsx
    59.8 KB · Affichages: 76
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour ibni, le forum,

J'ai recopié les lignes 8:606 du fichier MATOS sur 607:11987.

Bien sûr il y a ainsi des doublons mais c'est juste pour tester.

La macro du fichier (5 bis) s'exécute chez moi (Win 10 - Excel 2013) en un peu plus de 6 secondes, c'est très acceptable.

Je note que si toutes les cellules en colonne L sont colorées ça n'augmente guère la durée d'exécution.

Bonne journée.
 
Vote positif 0 Vote négatif
I

ibni

XLDnaute Nouveau
Bonjour Job,
dans le classeur d'origine (MATOS) les colonnes comme D,E,F,G contiennent des couleurs, est ce qu'il y'a possibilité de changer le code que vous m'avez fourni pour ne pas importer ces couleurs dans le fichier RECAP pour que toutes les cellules dans le fichier de destination soient sans couleur remplissage??

autre chose est ce que c'est possible d'importer les chiffres en valeurs et non pas avec formules ??

Merci d'avance
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re,

Fichier (6) avec ce code modifié :
Code: 
    If derlig > 7 Then
        .Range("A8:K" & derlig).Interior.ColorIndex = xlNone 'aucune couleur de fond
        .Range("A8:K" & derlig).Font.ColorIndex = xlAutomatic 'police sans couleur
        .Range("A8:K" & derlig).ClearComments 'supprime les commentaires
        .Range("J8:K" & derlig) = .Range("J8:K" & derlig).Value 'supprime les formules
        .Range("A8:K" & derlig).Copy F.[A8] 'copie tout le reste
    End If
Edit : voir post #28.

A+
 

Pièces jointes

  • RECAP(6).xlsm
    73.2 KB · Affichages: 58
  • MATOS.xlsx
    59.8 KB · Affichages: 83
Dernière édition:
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

24 membres et 314 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 489
Messages
2 110 134
Membres
110 682
dernier inscrit
mgaudi