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 ; )
Merci d'avance pour votre aide
Cordialement
An@s
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 SubMerci d'avance pour votre aide
Cordialement
An@s
