Supprimer des lignes incluant un mot (ou bout de mot)
Bonjour le forum
J'édite ce premier message, la seule chose qui ne fonctionne pas dans mon script est la macro de suppression des lignes parasites : quand elle est appelée je n'obtiens aucun résultat sur ma feuille Requete.
Le fichier doit compter les cases noires non vides et dont la date est antérieure au premier du mois, et ce pour tous les fichiers du dossier. LA première (petite) macro sert normalement à enlever les lignes dont la colonne C contient le mot "DEROG" (ou DEROGATION ou ALLODEROGUE ou...)
Sub SupLign()
Dim j As Long
For j = Range("C65536").End(xlUp).Row To 1 Step -1
If Not UCase(Cells(j, 3).Value) Like UCase("DEROG") Then Rows(j).Delete
Next j
End Sub
Sub Extraction()
Dim Principal As ThisWorkbook
Dim Repertoire As String, fichier As String
Dim I As Long
Dim DerLigneWip As Integer
Dim DerColWip As Integer
Dim nb As Long
Dim Plage As Range
Application.ScreenUpdating = False
Set Principal = ThisWorkbook
Repertoire = ThisWorkbook.Path
ChDir Repertoire
xFichier = Dir("*.xlsx")
Do While xFichier <> ""
If xFichier <> Principal.Name Then
Workbooks.Open xFichier
With Sheets("WIP_31-01-2017")
' Call SupLign
DerColWip = Cells(2, Columns.Count).End(xlToLeft).Column 'Détermination dernière colonne utilisée
DerLigneWip = Cells(Application.Rows.Count, ActiveCell.Column).End(xlUp).Row
Produit = .Range("B1")
' Set Plage = .Range(Cells(DerLigneWip, 8), Cells(DerLigneWip, DerColWip))
For I = 8 To DerColWip 'Détermination des dernières lignes de ce fichier pour les colonnes A à C
DerLigneC = ThisWorkbook.Sheets("Requete").Cells(Application.Rows.Count, 3).End(xlUp).Row
DerLigneB = ThisWorkbook.Sheets("Requete").Cells(Application.Rows.Count, 2).End(xlUp).Row
DerLigneA = ThisWorkbook.Sheets("Requete").Cells(Application.Rows.Count, 1).End(xlUp).Row
nb = 0
Set lacolonne = .Range(Cells(3, I), Cells(DerLigneWip, I)) 'Range de recherche sur le WIP
Set OP = .Columns(I).Rows(2) 'Nom de l'OP
For Each Cell In lacolonne
If Cell.Interior.ColorIndex = 1 And Cell.Value <> "" And Cell.Value < ThisWorkbook.Sheets("Requete").Range("L2").Value Then
nb = nb + 1 'On incrémente à chaque case
End If
Next Cell
ThisWorkbook.Sheets("Requete").Range("C" & DerLigneC + 1).Value = nb
ThisWorkbook.Sheets("Requete").Range("B" & DerLigneB + 1).Value = OP
ThisWorkbook.Sheets("Requete").Range("A" & DerLigneB + 1).Value = Produit
Next I
End With
End If
xFichier = Dir
ActiveWorkbook.Close savechanges:=False
Loop
Application.ScreenUpdating = True
End SubTrouvé ceci sur un autre forum :
Function NbreCellulesCouleur(Plage As Range, Couleur As Byte) As Long
'Compter le nombre de cellules d'une couleur donnée dans une plage donnée
'Plage: plage de cellules à inspecter
'Couleur: valeur de la couleur cherchée
Application.Volatile
Dim Cellule As Range
For Each Cellule In Plage
If Cellule.Interior.ColorIndex = Couleur And Not IsEmpty(Cellule) Then
NbreCellulesCouleur = NbreCellulesCouleur + 1
End If
Next Cellule
End FunctionJe ne suis pas certain qu'utiliser une Application volatile servent (quoique je n'en ai jamais utilisé).
En revanche je ne vois pas comment modifier le code pour compter mes cellules remplissant les trois conditions Couleur - Non vide - valeur inférieure à [date du début du mois définie en amont].
J'ai réussi à sortir un embryon de code. Ca boucle, c'est déjà bon signe !
Par contre mon "nb" n'augmente pas, il y a donc un soucis pour compter les cases noires contenant du texte :/
Ci-joint le code (le premier Sub est destiné à effacer des lignes parasites présentes dans certains fichiers).
Sub SupLign()
Dim i As Long
For i = Range("B65536").End(xlUp).Row To 1 Step -1
If Not UCase(Cells(i, 2).Value) Like UCase("DEROG") Then Rows(i).Delete
Next i
End Sub
--------------------------------------------------------------------------------------------------------------------------------------------------------
Sub Extraction()
Dim Principal As ThisWorkbook
Dim Repertoire As String, fichier As String
Dim i As Long
Dim DerLigneWip As Integer
Dim DerColWip As Integer
Dim nb As Long
Dim Plage As Range
Application.ScreenUpdating = False
Set Principal = ThisWorkbook
Repertoire = ThisWorkbook.Path
ChDir Repertoire
xFichier = Dir("*.xlsx")
Do While xFichier <> ""
If xFichier <> Principal.Name Then
Workbooks.Open xFichier
With Sheets("WIP_31-01-2017")
' Call SupLign
DerColWip = Cells(2, Columns.Count).End(xlToLeft).Column 'Détermination dernière colonne utilisée
DerLigneWip = Cells(Application.Rows.Count, ActiveCell.Column).End(xlUp).Row
Set Plage = .Range(Cells(DerLigneWip, 8), Cells(DerLigneWip, DerColWip))
For i = 8 To DerColWip
For Each Cell In Plage
nb = 0
lacolonne = Workbooks(xFichier).Sheets("WIP_31-01-2017").Range(Cells(4, i), Cells(DerLigneWip, i))
If Cell.Value <> "" And Cell.Interior.ColorIndex = 1 Then
nb = nb + 1
End If
Next Cell
Next i
End With
End If
xFichier = Dir
Loop
End SubUp et édition du premier post car avancement du projet
Edit : Je met le code ici au cas où ça servirait à quelqu'un. Le fichier marche.
Sub SupLign()
Dim j As Long
Dim Repertoire As String, fichier As String
Dim Principal As ThisWorkbook
Dim ladate As String
Dim TEST As Boolean
Dim xFichier As String
Dim derligne As Integer
ladate = ThisWorkbook.Sheets("Requete").Range("L3").Value 'Définition de la date des fichier WIP
Application.ScreenUpdating = False
Set Principal = ThisWorkbook
derligne = ThisWorkbook.Sheets("PIECES").Cells(Application.Rows.Count, 1).End(xlUp).Row
Repertoire = ThisWorkbook.Path
ChDir Repertoire
xFichier = Dir("*.xlsx")
Do While xFichier <> ""
If xFichier <> Principal.Name Then
Workbooks.Open xFichier
With Sheets("WIP_" & ladate)
For j = Range("C65536").End(xlUp).Row To 1 Step -1 'Deletion des lignes contenant les mots clefs suivants dans les colonnes C puis B
If UCase(Cells(j, 3).Value) Like UCase("*DEROG*") Then Rows(j).Delete
If UCase(Cells(j, 3).Value) Like UCase("*dero*") Then Rows(j).Delete
If UCase(Cells(j, 3).Value) Like UCase("*rebuter*") Then Rows(j).Delete
If UCase(Cells(j, 3).Value) Like UCase("*Quarantaine*") Then Rows(j).Delete
Next j
For I = Range("B65536").End(xlUp).Row To 1 Step -1
If UCase(Cells(I, 2).Value) Like UCase("*DEROG*") Then Rows(I).Delete
If UCase(Cells(I, 2).Value) Like UCase("*dero*") Then Rows(I).Delete
If UCase(Cells(I, 2).Value) Like UCase("*rebuter*") Then Rows(I).Delete
If UCase(Cells(I, 2).Value) Like UCase("*Quarantaine*") Then Rows(I).Delete
Next I
For k = Cells(2, Columns.Count).End(xlToLeft).Column To 1 Step -1 'Enlève les colonnes avec OP 900+
If IsNumeric(Cells(2, k).Value) And Cells(2, k).Value > 899 Then Columns(k).Delete
Next k
End With
End If
xFichier = Dir
ActiveWorkbook.Close savechanges:=True 'Enregistrement des changements dans les fichiers
Loop
Application.ScreenUpdating = True
End Sub
Sub Extraction()
Dim ladate As String
Dim Principal As ThisWorkbook
Dim Repertoire As String, fichier As String
Dim I As Long
Dim PremColWip As Integer
Dim DerLigneWip As Integer
Dim DerColWip As Integer
Dim nb As Long
ladate = ThisWorkbook.Sheets("Requete").Range("L3").Value
Application.ScreenUpdating = False
Set Principal = ThisWorkbook
Repertoire = ThisWorkbook.Path
ChDir Repertoire
xFichier = Dir("*.xlsx")
Do While xFichier <> ""
If xFichier <> Principal.Name Then 'On exclue ce fichier de la liste des fichiers à traiter
Workbooks.Open xFichier
With Sheets("WIP_" & ladate)
DerColWip = Cells(2, Columns.Count).End(xlToLeft).Column 'Détermination dernière colonne utilisée
DerLigneWip = Cells(Application.Rows.Count, ActiveCell.Column).End(xlUp).Row
Produit = .Range("B1")
For j = 1 To 8 'Determination de la première colonne OF (sur certains fichier ça commencent avant la colonne 8)
If Not IsEmpty(Cells(2, j).Value) And IsNumeric(Cells(2, j).Value) Then
PremColWip = j
Exit For
End If
Next j
For I = PremColWip To DerColWip 'Détermination des dernières lignes de ce fichier pour les colonnes A à C
DerLigneC = ThisWorkbook.Sheets("Requete").Cells(Application.Rows.Count, 3).End(xlUp).Row
DerLigneB = ThisWorkbook.Sheets("Requete").Cells(Application.Rows.Count, 2).End(xlUp).Row
DerLigneA = ThisWorkbook.Sheets("Requete").Cells(Application.Rows.Count, 1).End(xlUp).Row
nb = 0
Set lacolonne = .Range(Cells(3, I), Cells(DerLigneWip, I)) 'Range de recherche sur le WIP
Set OP = .Columns(I).Rows(2) 'Nom de l'OP
For Each Cell In lacolonne
If Cell.Interior.ColorIndex = 1 And Cell.Value <> "" And Cell.Value < ThisWorkbook.Sheets("Requete").Range("L2").Value Then
nb = nb + 1 'On incrémente à chaque cellule
End If
Next Cell
ThisWorkbook.Sheets("Requete").Range("C" & DerLigneC + 1).Value = nb
ThisWorkbook.Sheets("Requete").Range("B" & DerLigneB + 1).Value = OP
ThisWorkbook.Sheets("Requete").Range("A" & DerLigneB + 1).Value = Produit
Next I
End With
End If
xFichier = Dir
ActiveWorkbook.Close savechanges:=False
Loop
Application.ScreenUpdating = True
End Sub
Sub SupFile()
Dim Principal As Workbook
Dim derligne As Integer
Dim Repertoire As String
Dim xFichier As String
Application.ScreenUpdating = False
Set Principal = ThisWorkbook
derligne = Sheets("PIECES").Cells(Application.Rows.Count, 1).End(xlUp).Row
Repertoire = ThisWorkbook.Path
ChDir Repertoire
xFichier = Dir("*.xlsx")
Do While xFichier <> ""
If xFichier <> ThisWorkbook.Name Then
If Sheets("PIECES").Range("A1:A" & derligne).Find(xFichier, , xlValues, , xlByRows) Is Nothing Then 'Si le nom du fichier ne se trouve pas dans la liste
Kill xFichier 'Suppression du fichier
End If
End If
xFichier = Dir
Loop
Application.ScreenUpdating = True
End Sub