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

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

ibni

XLDnaute Nouveau
Bonjour Job, le forum Joyeux Noël à tous et à toutes

je reviens vers vous concernant la dernière modification du code ci-dessous que vous m'avez fournis.
le code fonctionne parfaitement mais je ne sais s'il y a possibilité de faire une rectification qui permet de ne pas importer aussi les lignes dont la valeur des cellules de la colonne J est égale à ZERO


VB:
Option Explicit

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$, derlig&, P As Range, code, coderest()
t = Timer
Set F = Feuil01 'CodeName de la feuille de destination
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
'---liste sans doublon des concaténations de A B C E F 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 = tablo(i, 1) & "#" & tablo(i, 2) & "#" & tablo(i, 3) & "#"
        x = x & tablo(i, 5) & "#" & tablo(i, 6) & "#" & tablo(i, 8)
        d(x) = i 'repérage de la ligne
    Next
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
    '---copie des "OT" de la 2ème feuille dans le même ordre---
    With .Parent.Sheets(2).Range("C15:G" & .Rows.Count)
        i = Application.CountIf(.Columns(1), "OT*")
        If i Then
            Set P = Intersect(.Cells, .Parent.UsedRange)
            P.UnMerge 'en cas de cellules fusionnées
            P.Columns(2) = "=IF(LEFT(RC[-1],2)=""OT"",ROW())" 'numérotation
            P.Columns(2) = P.Columns(2).Value 'supprime les formules
            .Sort .Columns(2), xlAscending, Header:=xlNo 'tri
            Union(P.Columns(2).Resize(, 3), P.Columns(6)) = ""
            Set P = .Resize(i, 6)
            P.Columns(5).Resize(, 5).Insert xlToRight 'donne 11 colonnes
            P.Font.Bold = False 'non gras, au cas où...
        End If
    End With
    If i Then P.Copy .Cells(derlig + 1, 1): derlig = derlig + i
    If derlig > 7 Then
        .Range("H8:K" & derlig).NumberFormat = "# ##0.00"  'ou "0.00" ou "# ##0.00 €"
        .Range("H8:K" & derlig).HorizontalAlignment = xlRight
        .Range("H8:K" & derlig).IndentLevel = 1
        .Range("J8:K" & derlig) = .Range("J8:K" & derlig).Value 'supprime les formules
        With .Range("A8:K" & derlig)
            .Interior.ColorIndex = xlNone 'aucune couleur de fond
            .Font.ColorIndex = xlAutomatic 'police sans couleur
            .ClearComments 'supprime les commentaires
            .Copy F.[A8] 'copie tout le reste
        End With
    End If
    .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)
    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 = tablo(i, 1) & "#" & tablo(i, 2) & "#" & tablo(i, 3) & "#"
        x = x & tablo(i, 5) & "#" & tablo(i, 6) & "#" & tablo(i, 8)
        If d.exists(x) Then coderest(i, 1) = code(d(x), 1)
    Next
    F.Range("L8:L" & derlig) = coderest
End If
'---finale---
F.Range("A8:L" & derlig).Borders.Weight = xlThin 'bordures
F.Range("A8:L" & derlig).Borders(xlInsideHorizontal).LineStyle = xlDot '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
 

job75

XLDnaute Barbatruc
Bonjour ibni,

Il suffit de supprimer les lignes avec zéro en colonne J en même temps que les lignes en "gras" :
Code:
'---suppression des lignes en gras ou contenant 0 en colonne J---
F.[L:L].Insert 'insertion d'une colonne auxiliaire devant la colonne L
With F.Range("L8:L" & derlig)
    .FormulaR1C1 = "=1/OR(Gras(RC1),RC10=0)" '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" ni de 0 en colonne J
    Intersect(.SpecialCells(xlCellTypeConstants, 1).EntireRow, F.[A:L]).Delete xlUp
End With
F.[L:L].Delete 'suppression de la colonne auxiliaire
Bonne fin de ce beau week-end de Noël.
 

job75

XLDnaute Barbatruc
Re,

Le code précédent supprime aussi les lignes dont la cellule en colonne J est vide.

Si l'on veut conserver ces lignes il faut comparer des textes :
Code:
'---suppression des lignes en gras ou contenant 0 en colonne J---
F.[L:L].Insert 'insertion d'une colonne auxiliaire devant la colonne L
With F.Range("L8:L" & derlig)
    .FormulaR1C1 = "=1/OR(Gras(RC1),""""&RC10=""0"")" '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" ou de 0 en colonne J
    Intersect(.SpecialCells(xlCellTypeConstants, 1).EntireRow, F.[A:L]).Delete xlUp
End With
F.[L:L].Delete 'suppression de la colonne auxiliaire
A+
 

ibni

XLDnaute Nouveau
re,
je viens de tester le code sur mon fichier que vous trouverez ci-joint et ça fonctionne très bien surtout ça s’exécute plus vite parce qu’il a éliminé toutes les lignes inutiles (celles avec les cellules O et vides).

maintenant j'ai créé un onglet que j'ai appelé Tri et j'aimerais savoir est ce que c'est possible de créer un code qui me permet une fois je clique sur l'onglet Tri de classer les données de l'onglet FAC par désignation et la somme des quantité (colonne A et colonne D)
j'ai donné un exemple dans le tableau souhaité sur l'onglet Tri:
par exemple le materiel <<Armoire vestiaire double>> se trouve sur 5 cellules de la colonne A (onglet Fac),
alors on met dans la colonne A(Onglet Tri) la désignation et dans la colonne B (quantité) la somme de D9 D13 (onglet Fac) qui égale 13
est ce que c'est possible de réaliser ça ??
 

Pièces jointes

  • RECAP.xlsm
    37.5 KB · Affichages: 38

job75

XLDnaute Barbatruc
Bonjour ibni, le forum,

C'est hors sujet mais comme c'est une utilisation très classique du Dictionary voici le code de la feuille "Tri" :
Code:
Private Sub Worksheet_Activate()
Dim d As Object, derlig&, t, i&
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
With Feuil01 'CodeName de la feuille "FAC"
  derlig = Application.Match("zzz", .[A:A])
  If derlig < 8 Then GoTo 1
  t = .Range("A8:D" & derlig)
End With
For i = 1 To derlig - 7
  If t(i, 1) <> "" Then d(t(i, 1)) = d(t(i, 1)) + Val(t(i, 4))
Next
With Range("A8:B" & d.Count + 7)
  .Columns(1) = Application.Transpose(d.keys) 'maximum 65536 lignes
  .Columns(2) = Application.Transpose(d.items)
  .Borders.Weight = xlThin 'bordures
  .Borders(xlInsideHorizontal).LineStyle = xlDot 'bordures
  .Columns(1).AutoFit 'ajustement largeur
End With
1 Rows(d.Count + 8 & ":" & Rows.Count).Delete 'RAZ en dessous du tableau
With Me.UsedRange: End With 'actualise la barre de défilement verticale
End Sub
Et mettez la colonne B aux formats qu'il faut.

Bonne journée.
 

ibni

XLDnaute Nouveau
Bonjour Job, le forum,

en appliquant votre code sur mon fichier j'ai eu le résultat que vous trouverez ci-joint
le format de la la colonne B se transforme automatiquement en monétaire,
y'a t'il possibilité de mettre la mise en forme automatiquement en nombre sans décimale ??
autre chose peut-on exclure les lignes dont les cellules de la colonne B est vide ou égale à Zero (lignes 28:30) ??

Cordialement
 

Pièces jointes

  • RECAP.xlsm
    41 KB · Affichages: 40

job75

XLDnaute Barbatruc
Re,

Bis repetita :
Et mettez la colonne B aux formats qu'il faut.
Pour le reste :
Code:
Private Sub Worksheet_Activate()
Dim d As Object, derlig&, t, i&
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
With Feuil01 'CodeName de la feuille "FAC"
  derlig = Application.Match("zzz", .[A:A])
  If derlig < 8 Then GoTo 1
  t = .Range("A8:D" & derlig)
End With
For i = 1 To derlig - 7
  If t(i, 1) <> "" And Val(t(i, 4)) <> 0 Then d(t(i, 1)) = d(t(i, 1)) + Val(t(i, 4))
Next
With Range("A8:B" & d.Count + 7)
  .Columns(1) = Application.Transpose(d.keys) 'maximum 65536 lignes
  .Columns(2) = Application.Transpose(d.items)
  .Borders.LineStyle = xlContinuous 'bordures
  .Borders.Weight = xlThin 'bordures
  .Borders(xlInsideHorizontal).LineStyle = xlDot 'bordures
  .Columns(1).AutoFit 'ajustement largeur
End With
1 Rows(d.Count + 8 & ":" & Rows.Count).Delete 'RAZ en dessous du tableau
With Me.UsedRange: End With 'actualise la barre de défilement verticale
End Sub
Edit : ajouté .Borders.LineStyle = xlContinuous car la bordure de la dernière ligne n'allait pas.

A+
 
Dernière édition:

ibni

XLDnaute Nouveau
Merci infiniment Job pour ce merveilleux travail,
j'ai changé le format de la colonne B manuellement,
par contre j'ai une petite question qui m'intrigue un peu, toutes les cellules de la feuille Tri sont devenues en format monétaire est ce que ça une liaison avec votre code, parce que même en ajoutant des feuilles après la feuille Tri je trouve que le format est automatiquement monétaire.

Bonne fin de soirée
 

job75

XLDnaute Barbatruc
Bonjour ibni, le forum,
par contre j'ai une petite question qui m'intrigue un peu, toutes les cellules de la feuille Tri sont devenues en format monétaire est ce que ça une liaison avec votre code
Mes codes n'y sont pour rien il s'agit du Style appliqué aux cellules de votre fichier.

Onglet Accueil => Style de cellules => clic droit sur Normal => Modifier.

Vous voyez que le format Nombre de ce style Normal est un format monétaire, remplacez-le par Standard.

A+
 

Pièces jointes

  • RECAP(1).xlsm
    43.5 KB · Affichages: 41

ibni

XLDnaute Nouveau
Bonjour Job, Le forum
je reviens vers vous concernant le code ci-dessous que vous m'avez fournis la dernière fois qui fait l'importation des données sauf celles en Gras.
plus de ça il importe même les données qui commencent avec OT de la colonne C (feuille 2 classeur Matos)

ce que je souhaite faire c'est en plus des OT Importer même les données de la colonne C (feuille 2 classeur Matos) qui commencent avec <<Refacturation>> et les coller après OT

Merci par avance

VB:
Option Explicit

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$, derlig&, P As Range, code, coderest()
t = Timer
Set F = Feuil01 'CodeName de la feuille de destination
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
'---liste sans doublon des concaténations de A B C E F 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 = tablo(i, 1) & "#" & tablo(i, 2) & "#" & tablo(i, 3) & "#"
        x = x & tablo(i, 5) & "#" & tablo(i, 6) & "#" & tablo(i, 8)
        d(x) = i 'repérage de la ligne
    Next
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
    '---copie des "OT" de la 2ème feuille dans le même ordre---
    With .Parent.Sheets(2).Range("C15:G" & .Rows.Count)
        i = Application.CountIf(.Columns(1), "OT*")
        If i Then
            Set P = Intersect(.Cells, .Parent.UsedRange)
            P.UnMerge 'en cas de cellules fusionnées
            P.Columns(2) = "=IF(LEFT(RC[-1],2)=""OT"",ROW())" 'numérotation
            P.Columns(2) = P.Columns(2).Value 'supprime les formules
            .Sort .Columns(2), xlAscending, Header:=xlNo 'tri
            Union(P.Columns(2).Resize(, 3), P.Columns(6)) = ""
            Set P = .Resize(i, 6)
            P.Columns(5).Resize(, 5).Insert xlToRight 'donne 11 colonnes
            P.Font.Bold = False 'non gras, au cas où...
        End If
    End With
    If i Then P.Copy .Cells(derlig + 1, 1): derlig = derlig + i
    If derlig > 7 Then
        .Range("H8:K" & derlig).NumberFormat = "# ##0.00"  'ou "0.00" ou "# ##0.00 €"
        .Range("H8:K" & derlig).HorizontalAlignment = xlRight
        .Range("H8:K" & derlig).IndentLevel = 1
        .Range("J8:K" & derlig) = .Range("J8:K" & derlig).Value 'supprime les formules
        With .Range("A8:K" & derlig)
            .Interior.ColorIndex = xlNone 'aucune couleur de fond
            .Font.ColorIndex = xlAutomatic 'police sans couleur
            .ClearComments 'supprime les commentaires
            .Copy F.[A8] 'copie tout le reste
        End With
    End If
    .Parent.Close False
    If derlig < 8 Then derlig = 7: GoTo 1
End With
'---suppression des lignes en gras ou contenant 0 ou vides en colonne J---
F.[L:L].Insert 'insertion d'une colonne auxiliaire devant la colonne L
With F.Range("L8:L" & derlig)
    .FormulaR1C1 = "=1/OR(Gras(RC1),RC10=0)" '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" ni de 0 en colonne J
    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)
    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 = tablo(i, 1) & "#" & tablo(i, 2) & "#" & tablo(i, 3) & "#"
        x = x & tablo(i, 5) & "#" & tablo(i, 6) & "#" & tablo(i, 8)
        If d.exists(x) Then coderest(i, 1) = code(d(x), 1)
    Next
    F.Range("L8:L" & derlig) = coderest
End If
'---finale---
F.Range("A8:L" & derlig).Borders.Weight = xlThin 'bordures
F.Range("A8:L" & derlig).Borders(xlInsideHorizontal).LineStyle = xlDot '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
 

job75

XLDnaute Barbatruc
Bonjour ibni,

Vous n'en avez toujours pas fini ?
Code:
Sub Importer()
Dim t#, F As Worksheet, d As Object, derlig1&, tablo, i&, x$, derlig&, P As Range, code, coderest()
t = Timer
Set F = Feuil01 'CodeName de la feuille de destination
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
'---liste sans doublon des concaténations de A B C E F 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 = tablo(i, 1) & "#" & tablo(i, 2) & "#" & tablo(i, 3) & "#"
        x = x & tablo(i, 5) & "#" & tablo(i, 6) & "#" & tablo(i, 8)
        d(x) = i 'repérage de la ligne
    Next
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
    '---copie des "OT" et des "Refacturation" de la 2ème feuille---
    With .Parent.Sheets(2).Range("C15:G" & .Rows.Count)
        i = Application.CountIf(.Columns(1), "OT*")
        i = i + Application.CountIf(.Columns(1), "Refacturation*")
        If i Then
            Set P = Intersect(.Cells, .Parent.UsedRange)
            P.UnMerge 'en cas de cellules fusionnées
            P.Columns(2) = "=IF(LEFT(RC[-1],2)=""OT"",1,IF(LEFT(RC[-1],13)=""Refacturation"",2))" 'numérotation
            P.Columns(2) = P.Columns(2).Value 'supprime les formules
            .Sort .Columns(2), xlAscending, Header:=xlNo 'tri
            Union(P.Columns(2).Resize(, 3), P.Columns(6)) = ""
            Set P = .Resize(i, 6)
            P.Columns(5).Resize(, 5).Insert xlToRight 'donne 11 colonnes
            P.Font.Bold = False 'non gras, au cas où...
        End If
    End With
    If i Then P.Copy .Cells(derlig + 1, 1): derlig = derlig + i
    If derlig > 7 Then
        .Range("H8:K" & derlig).NumberFormat = "# ##0.00"  'ou "0.00" ou "# ##0.00 €"
        .Range("H8:K" & derlig).HorizontalAlignment = xlRight
        .Range("H8:K" & derlig).IndentLevel = 1
        .Range("J8:K" & derlig) = .Range("J8:K" & derlig).Value 'supprime les formules
        With .Range("A8:K" & derlig)
            .Interior.ColorIndex = xlNone 'aucune couleur de fond
            .Font.ColorIndex = xlAutomatic 'police sans couleur
            .ClearComments 'supprime les commentaires
            .Copy F.[A8] 'copie tout le reste
        End With
    End If
    .Parent.Close False
    If derlig < 8 Then derlig = 7: GoTo 1
End With
'---suppression des lignes en gras ou contenant 0 en colonne J---
F.[L:L].Insert 'insertion d'une colonne auxiliaire devant la colonne L
With F.Range("L8:L" & derlig)
    .FormulaR1C1 = "=1/OR(Gras(RC1),RC10=0)" '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" ni de 0 en colonne J
    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)
    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 = tablo(i, 1) & "#" & tablo(i, 2) & "#" & tablo(i, 3) & "#"
        x = x & tablo(i, 5) & "#" & tablo(i, 6) & "#" & tablo(i, 8)
        If d.exists(x) Then coderest(i, 1) = code(d(x), 1)
    Next
    F.Range("L8:L" & derlig) = coderest
End If
'---finale---
F.Range("A8:L" & derlig).Borders.Weight = xlThin 'bordures
F.Range("A8:L" & derlig).Borders(xlInsideHorizontal).LineStyle = xlDot '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" 'mesure facultative
End Sub
A+
 

Discussions similaires

Réponses
12
Affichages
225

Statistiques des forums

Discussions
311 720
Messages
2 081 925
Membres
101 841
dernier inscrit
ferid87