importation données sauf des lignes précises (Code de Job)

an@s

XLDnaute Occasionnel
Bonjour à tous,
je reviens vers vous encore une autre fois pour solliciter votre aide afin que vous m'aidiez pour une petite modification sur le code ci-dessous (fait par Job auparavant)

au fait le code importe toutes les données d'un fichier appelé matos sauf les lignes qui sont en Gras ou qui contiennent ZERO dans la colonne J.

la condition que je veux rajouter c'est que le code n'importe pas aussi les lignes dont la colonne J est : ( , ou ; )

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" 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

Merci d'avance pour votre aide

Cordialement
An@s
 

an@s

XLDnaute Occasionnel
Bonsoir Job, le forum,

le code n'importe pas les lignes qui sont en gras et celles dont la colonne J contient un zero.
j'aimerai rajouter une condition pour que le code n'importe pas entre autre les lignes dont la colonne J contient une virgule ou point virgule

j'ai essayé de rajouter cette condition de cette manière
VB:
 .FormulaR1C1 = "=1/OR(Gras(RC1),RC10=0, RC10=, )" 'utilise la fonction
mais ça ne focntionne pas

Merci pour votre réponse
An@s
 

an@s

XLDnaute Occasionnel
Re,
(la formule que vous m'avez donnée enlève toutes les cellules qui contiennent des chiffres avec virgule)
je suis désolé je me suis mal exprimé...
effectivement je voulais dire si la cellule de la colonne J égale vigule ou point virgule ( =, ou = ; )

Merci d'avance
 

Discussions similaires