Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

  • Initiateur de la discussion Initiateur de la discussion ibni
  • Date de début Date de début
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
I

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
 
Vote positif 0 Vote négatif

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.
 
Vote positif 0 Vote négatif

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+
 
Vote positif 0 Vote négatif
I

ibni

XLDnaute Nouveau
Super, Merci beaucoup Job j'ai oublié les cellules vides, je préfére le premier code dans ce cas
je vais essayer de l'appliquer sur mon fichier d'origine et je vous tiens au courant

Bonne fin de week end
Ibni
 
Vote positif 0 Vote négatif
I

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
Vote positif 0 Vote négatif

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.
 
Vote positif 0 Vote négatif
I

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
Vote positif 0 Vote négatif

job75

XLDnaute Barbatruc
Re,

Bis repetita :
job75 à dit:
Et mettez la colonne B aux formats qu'il faut.
Cliquez pour agrandir...
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:
Vote positif 0 Vote négatif
I

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
 
Vote positif 0 Vote négatif

job75

XLDnaute Barbatruc
Bonjour ibni, le forum,
ibni à dit:
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
Cliquez pour agrandir...
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
Vote positif 0 Vote négatif
I

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
 
Vote positif 0 Vote négatif

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+
 
Vote positif 0 Vote négatif
I

ibni

XLDnaute Nouveau
re,
après avoir fait un test j'ai constaté que le code importe la ligne de refacturation mais le problème c'est qu'il ne fait plus sont travail d'origine c'est à dire il importe même les lignes en Gras
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

  • Résolu(e)
XL 2016 Indice n'appartient pas à la sélection : HELP !!!!
2
Réponses
21
Affichages
1 K
halecs93
N
  • Question Question
XL 2019 Mettre en gras éléments du graphique avec macro
Réponses
4
Affichages
673
Nasseuz
N
S
  • Question Question
XL 2016 Problème dans la création d'une liste
Réponses
2
Affichages
332
Stéphane_1
S
L
  • Résolu(e)
Microsoft 365 Suppression de cellules vide
Réponses
3
Affichages
431
Le Rouky
L
A
  • Question Question
Microsoft 365 Code VBA Envoi contenu tableau Excel par Email
Réponses
1
Affichages
415
Phil69970
D
  • Question Question
envois automatique d'email avec EXCEL et une MACRO
Réponses
4
Affichages
945
AtTheOne
  • Question Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
1 K
Nicolas JACQUIN
B
  • Question Question
Microsoft 365 Additionner des cellules même ligne en userform vba
Réponses
13
Affichages
648
sousou
I
  • Question Question
Microsoft 365 SOMMEPROD en vba excel
Réponses
12
Affichages
460
iliess
I
M
  • Question Question
XL 2019 Optimisation de code VBA
2 3
Réponses
33
Affichages
2 K
mmaiga
M
I
  • Résolu(e)
Microsoft 365 remplir un tableau Arr() en vba à partir des cellules visible
Réponses
4
Affichages
834
iliess
I
  • Résolu(e)
XL 2019 Organiser les données dans listbox
Réponses
2
Affichages
700
Messan
M
  • Question Question
XL 2016 VBA Liste déroulante
Réponses
2
Affichages
711
Myaah
M
  • Résolu(e)
XL 2016 Récupérer les données de nom et de date VBA
2 3
Réponses
35
Affichages
2 K
Oneida
L
  • Question Question
XL 2019 Excel - utilisation des unbound pour grande base de donnees
Réponses
11
Affichages
821
Lordpeter
L
A
  • Résolu(e)
XL 2016 Boucle
Réponses
12
Affichages
811
Aldonanou
A
U
  • Question Question
Autres Enregistrer sur Onglet TOTO
Réponses
2
Affichages
505
un internaute
U
S
  • Question Question
Microsoft 365 Ajout d'une en-tete et pied de page via macro
Réponses
4
Affichages
964
saggigo
S
  • Résolu(e)
Microsoft 365 lister des fichiers
2
Réponses
19
Affichages
2 K
Usine à gaz
B
  • Question Question
Microsoft 365 formulaire VBA problème
Réponses
3
Affichages
843
herve62
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…