Sub LISTE_ONGLETS Dim Feuile As Worksheet, derniereligne As Long, Maplage As Range Dim LigneDestinationSurFeuilMacro As Long With Sheets("MACRO").Cells .ClearContents .Borders.LineStyle = xlNone .Interior.ColorIndex = xlAutomatic End With LigneDestinationSurFeuilMacro = 1 For Each feuille In ThisWorkbook.Worksheets With feuille 'le if sert à trouver les feuilles 'à prendre en compte. Pour cela je me suit basé 'sur la Cellule A2 qui contient la chaine "Légende" 'Attention si tu déplaces ce texte ou le remplace cela ne fonctionnera plus If .Range("A2").Value = "Légende" Then derniereligne = .Range("A" & .Columns("A").Rows.Count).End(xlUp).Row Set Maplage = .Range("A6:J" & derniereligne) Maplage.AutoFilter Field:=1, Criteria1:="<>" Maplage.SpecialCells(xlCellTypeVisible).Copy Destination:=Worksheets("Macro").Range("A" & LigneDestinationSurFeuilMacro) LigneDestinationSurFeuilMacro = Worksheets("Macro").Range("A" & .Columns("A").Rows.Count).End(xlUp).Row + 1 Maplage.AutoFilter End If End With Next End Sub
Sub macro_numero() Dim Feuille As Worksheet '*** affecter numéro *** numero = 1 suivant = Worksheets("Extraction").Range("E4") '*** trouver et attribuer les numéros *** For Each Feuille In ThisWorkbook.Worksheets With Feuille If .Range("A2").Value = "Légende" Then With Feuille.Range("J:J") Set trouver_x = .Find("x") ' ça bloque ici avec " erreur de compilation : 'Méthode ou membre de données introuvable If Not trouver_x Is Nothing Then Do trouver_x.Value = suivant + numero Set trouver_x = .FindNext(trouver_x) numero = numero + 1 Loop While Not trouver_x Is Nothing End If End With End If End With Next End Sub
Enfin, le 3e bouton me permet en fait de garder un 'historique' de mes commandes. J'aimerais donc qu'en appuyant sur 'supprimer' les lignes en gris clair (couleur excel 2003) s'effacent (dans les tableaux des agents) et viennent se mettre dans la feuille "Synthèse", sans effacer les 'commandes' précédentes. Je suis en ce moment même en train de me brûler des neurones là dessus. Étant donnée que la macro enregistrée pour la recherche d'une case suivant son format de couleur n'est pas vraiment fonctionnelle lorsque l'on essaye de la ré-appliquée en vba... un peu d'aide serait la bienvenue également.
Sub SUPPR() Dim Cell As Range, derniereligne As Long, Maplage As Range Dim i As Integer Dim Feuille As Worksheet Dim LigneDestinationSurSynthese As Long 'commencer à la première ligne vide For Each Feuille In ThisWorkbook.Worksheets ' Pour chaque feuille de ce fichier With Feuille If .Range("A2").Value = "Légende" Then ' prendre seulement les onglet agent derniereligne = .Range("A" & .Columns("A").Rows.Count).End(xlUp).Row 'numero de la dernière ligne Set Maplage = .Range("A7:J" & derniereligne) 'plage dans le tableau ou il y a des données i = 1 Do Set Cell = Maplage.Cells(i, 1) If Cell.Interior.ColorIndex = 15 Then ' /!\ couleur gris clair excel 2003 ????? LigneDestinationSurSynthese = Worksheets("Synthèse").Range("A" & .Columns("A").Rows.Count).End(xlUp).Row + 1 'la prochaine ligne de destination Cell.EntireRow.Copy Destination:=Worksheets("Synthèse").Range("A" & LigneDestinationSurSynthese) 'couper/coller Cell.EntireRow.Delete shift:=xlUp Else i = i + 1 End If DoEvents Loop Until i > Maplage.Rows.Count End If End With Next End Sub
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre questionLe premier bouton sur l'onglet "Extraction" va en fait prendre les données des onglets "agent" qui sont les onglet avec 2 lettres, et les regrouper sur la page "Macro" évidemment comme vous avez pu le constater dès qu'il y a un espace, il passe à l'onglet suivant. Sachant que l'espace me sers en fait de séparateur entre chaque jour, je n'ai pas encore réussi à faire une liste complète. un peu d'aide m'enlèvera une épine du pied :)
Sub LISTE_ONGLETS() 'nom des feuilles : F_1 = "CF" F_2 = "NB" F_3 = "JM" F_4 = "Mel" F_5 = "MA" F_6 = "PL" F_7 = "VR" F_8 = "SM" F_9 = "MG" 'supprimer les données de la feuille 'MACRO' Sheets("MACRO").Select Cells.Select Selection.ClearContents ' j'aurais pu faire que clearcontent mais vu que j'ai besoin des couleurs dans la liste il me faut tout bien effacer. Selection.Interior.ColorIndex = xlNone Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone Selection.Borders(xlEdgeLeft).LineStyle = xlNone Selection.Borders(xlEdgeTop).LineStyle = xlNone Selection.Borders(xlEdgeBottom).LineStyle = xlNone Selection.Borders(xlEdgeRight).LineStyle = xlNone Selection.Borders(xlInsideVertical).LineStyle = xlNone Selection.Borders(xlInsideHorizontal).LineStyle = xlNone Range("A1").Select 'chercher dans CF - /!\ je pense que c'est à partir de là qu'il y a moyen de faire mieux je pense.. Sheets(F_1).Select Range("A6").Select Range(Selection, Selection.End(xlDown)).Select Range(Selection, Selection.End(xlToRight)).Select Application.CutCopyMode = False Selection.Copy Sheets("MACRO").Select ActiveSheet.Paste 'chercher dans NB Sheets(F_2).Select Call chercher 'permet de trouver la premiere case vide et de coller 'chercher dans JM Sheets(F_3).Select Call chercher 'permet de trouver la premiere case vide et de coller 'chercher dans Mel Sheets(F_4).Select Call chercher 'permet de trouver la premiere case vide et de coller 'chercher dans MA Sheets(F_5).Select Call chercher 'permet de trouver la premiere case vide et de coller 'chercher dans PL Sheets(F_6).Select Call chercher 'permet de trouver la premiere case vide et de coller 'chercher dans VR Sheets(F_7).Select Call chercher 'permet de trouver la premiere case vide et de coller 'chercher dans SM Sheets(F_8).Select Call chercher 'permet de trouver la premiere case vide et de coller 'chercher dans MG Sheets(F_9).Select Call chercher 'permet de trouver la premiere case vide et de coller End Sub Private Sub chercher() Range("A6").Select Range(Selection, Selection.End(xlToRight)).Select Range(Selection, Selection.End(xlDown)).Select Application.CutCopyMode = False Selection.Copy Sheets("MACRO").Select 'recherche la première ligne vide With Range("A:A") Set vide = .Find("") End With vide.Select ActiveSheet.Paste ' et colle les données End Sub
Sub LISTE_ONGLETS() 'nom des feuilles : F_1 = "CF" F_2 = "NB" F_3 = "JM" F_4 = "Mel" F_5 = "MA" F_6 = "PL" F_7 = "VR" F_8 = "SM" F_9 = "MG" 'supprimer les données de la feuille 'MACRO' Sheets("MACRO").Select Cells.Select Selection.ClearContents ' j'aurais pu faire que clearcontent mais vu que j'ai besoin des couleurs dans la liste il me faut tout bien effacer. Selection.Interior.ColorIndex = xlNone Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone Selection.Borders(xlEdgeLeft).LineStyle = xlNone Selection.Borders(xlEdgeTop).LineStyle = xlNone Selection.Borders(xlEdgeBottom).LineStyle = xlNone Selection.Borders(xlEdgeRight).LineStyle = xlNone Selection.Borders(xlInsideVertical).LineStyle = xlNone Selection.Borders(xlInsideHorizontal).LineStyle = xlNone Range("A1").Select
Sub LISTE_ONGLETS() 'nom des feuilles : F_1 = "CF" F_2 = "NB" F_3 = "JM" F_4 = "Mel" F_5 = "MA" F_6 = "PL" F_7 = "VR" F_8 = "SM" F_9 = "MG" 'supprimer les données de la feuille 'MACRO' With Sheets("MACRO").Cells .ClearContents .Borders.LineStyle = xlNone end With
Sub MAJ_nom() ActiveWorkbook.Names("onglets_agent").Delete Range("I3").Select Range(Selection, Selection.End(xlDown)).Select ActiveWorkbook.Names.Add Name:="onglets_agents", RefersToR1C1:= _ Selection For Each rw In Range("onglets_agents") 'mettre à ce moment la macro une seule fois ici.. Next End Sub
Note que la méthode utilisée supprime les lignes rouge !
Sur le deuxième bouton qui est un des plus important , il me permet d'affecter un numéro ( qui correspond en fait au numéro maximum du classeur + 1 ) si l'agent a mis un 'x' sous "numéro de camion". Cependant il est INCROYABLEMENT long puisque le fichier sera par la suite partagé!
Je me demandais si une âme généreuse aurait une idée pour réduire le temps de chargement. sans partage il prends 1-2 secondes et en partage il mets bien 30 à 90 voire 180 secondes.. je pense que le partage y est pour beaucoup mais j'espérais un peu plus rapide étant donné que mon code est assez simplissime et que je pense pouvoir faire mieux aux niveau de la passation de paramètres... (j'avais pensé à mettre une liste des onglets à prendre, mais je me suis pas encore vraiment penché à fond dessus)
Sub macro_numero() 'nom des feuilles : F_1 = "CF" F_2 = "NB" F_3 = "JM" F_4 = "Mel" F_5 = "MA" F_6 = "PL" F_7 = "VR" F_8 = "SM" F_9 = "MG" 'Préparation de l'onglet synthèse, vide la zone de collecte des données Sheets("BDD").Select Range("A2").Select Range(Selection, Selection.End(xlDown)).Select Selection.ClearContents 'Sélectionne la feuille qu'il faut copier Sheets(F_1).Select Range("J7:J89").Select Application.CutCopyMode = False Selection.Copy Sheets("BDD").Select Range("A2").Select 'sélectionne la cellule ou il faut coller Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'supprimer les vides. With Range("A2", Range("A65000").End(xlUp)). _ SpecialCells(xlCellTypeBlanks).EntireRow.Delete End With Sheets(F_2).Select 'feuille 02 Range("J7:J89").Select Application.CutCopyMode = False Selection.Copy Sheets("BDD").Select Range("A2000").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'supprimer les vides. 'ActiveSheet.Range("A30").CurrentRegion.Select With Range("A2", Range("A65000").End(xlUp)). _ SpecialCells(xlCellTypeBlanks).EntireRow.Delete End With Sheets(F_3).Select 'feuille 03 Range("J7:J89").Select Application.CutCopyMode = False Selection.Copy Sheets("BDD").Select Range("A2000").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'supprimer les vides. 'ActiveSheet.Range("A30").CurrentRegion.Select With Range("A2", Range("A65000").End(xlUp)). _ SpecialCells(xlCellTypeBlanks).EntireRow.Delete End With Sheets(F_4).Select 'feuille 04 Range("J7:J89").Select Application.CutCopyMode = False Selection.Copy Sheets("BDD").Select Range("A2000").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'supprimer les vides. 'ActiveSheet.Range("A30").CurrentRegion.Select With Range("A2", Range("A65000").End(xlUp)). _ SpecialCells(xlCellTypeBlanks).EntireRow.Delete End With Sheets(F_5).Select 'feuille 05 Range("J7:J89").Select Application.CutCopyMode = False Selection.Copy Sheets("BDD").Select Range("A2000").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'supprimer les vides. 'ActiveSheet.Range("A30").CurrentRegion.Select With Range("A2", Range("A65000").End(xlUp)). _ SpecialCells(xlCellTypeBlanks).EntireRow.Delete End With Sheets(F_6).Select 'feuille 06 Range("J7:J89").Select Application.CutCopyMode = False Selection.Copy Sheets("BDD").Select Range("A2000").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'supprimer les vides. 'ActiveSheet.Range("A30").CurrentRegion.Select With Range("A2", Range("A65000").End(xlUp)). _ SpecialCells(xlCellTypeBlanks).EntireRow.Delete End With Sheets(F_7).Select 'feuille 07 Range("J7:J89").Select Application.CutCopyMode = False Selection.Copy Sheets("BDD").Select Range("A2000").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'supprimer les vides. 'ActiveSheet.Range("A30").CurrentRegion.Select With Range("A2", Range("A65000").End(xlUp)). _ SpecialCells(xlCellTypeBlanks).EntireRow.Delete End With Sheets(F_8).Select 'feuille 08 Range("J7:J89").Select Application.CutCopyMode = False Selection.Copy Sheets("BDD").Select Range("A2000").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'supprimer les vides. 'ActiveSheet.Range("A30").CurrentRegion.Select With Range("A2", Range("A65000").End(xlUp)). _ SpecialCells(xlCellTypeBlanks).EntireRow.Delete End With Sheets(F_9).Select 'feuille 09 Range("J7:J89").Select Application.CutCopyMode = False Selection.Copy Sheets("BDD").Select Range("A2000").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'supprimer les vides. 'ActiveSheet.Range("A30").CurrentRegion.Select With Range("A2", Range("A65000").End(xlUp)). _ SpecialCells(xlCellTypeBlanks).EntireRow.Delete End With Sheets("Extraction").Select 'affecter numéro numero = 1 suivant = Worksheets("Extraction").Range("E4") Feuille = F_1 Call attribuer(Feuille, numero, suivant) Feuille = F_2 Call attribuer(Feuille, numero, suivant) Feuille = F_3 Call attribuer(Feuille, numero, suivant) Feuille = F_4 Call attribuer(Feuille, numero, suivant) Feuille = F_5 Call attribuer(Feuille, numero, suivant) Feuille = F_6 Call attribuer(Feuille, numero, suivant) Feuille = F_7 Call attribuer(Feuille, numero, suivant) Feuille = F_8 Call attribuer(Feuille, numero, suivant) Feuille = F_9 Call attribuer(Feuille, numero, suivant) End Sub Private Sub attribuer(Feuille, numero, suivant) With Worksheets(Feuille).Range("J7:J89") Set c = .Find("x", LookIn:=xlValues) If Not c Is Nothing Then Do c.Value = suivant + numero Set c = .FindNext(c) numero = numero + 1 Loop While Not c Is Nothing End If End With End Sub
Sub macro_numero() Dim Feuille As Worksheet LigneDestinationSurFeuilMacro = 1 For Each Feuille In ThisWorkbook.Worksheets With Feuille If .Range("A2").Value = "Légende" Then Set trouver_x = .Find("x", LookIn:=xlValues) ' ça bloque ici avec " erreur de compilation : 'Méthode ou membre de données introuvable If Not trouver_x Is Nothing Then Do trouver_x.Value = suivant + numero Set trouver_x = .FindNext(c) numero = numero + 1 Loop While Not trouver_x Is Nothing End If End If End With Next End Sub
Sub SUPPR() Dim Cell As Range Dim Feuille As Worksheet For Each Feuille In ThisWorkbook.Worksheets ' Pour chaque feuille de ce fichier With Feuille For Each Cell In Feuille 'j'avais pensé mettre à la place de 'Feuille' mettre 'maplage' (en définissant la variable avant bien sur) peut etre que c'est plus pratique.. If Cell.Interior.ColorIndex = 3 Then ' le gris clair basic de excel 2003 c'est quel chiffre ? End If Next End With Next End Sub
Sub SUPPR() Dim Cell As Range, derniereligne As Long, Maplage As Range Dim Feuille As Worksheet, LigneDestinationSurFeuilMacro As Long LigneDestinationSurFeuilMacro = Worksheets("Synthèse").Range("A" & .Columns("A").Rows.Count).End(xlUp).Row 'commencer à la première ligne vide; CA BLOQUE A .Columns avec "erreur de compilation", une nouvelle fois.. For Each Feuille In ThisWorkbook.Worksheets ' Pour chaque feuille de ce fichier With Feuille If .Range("A2").Value = "Légende" Then ' prendre seulement les onglet agent derniereligne = .Range("A" & .Columns("A").Rows.Count).End(xlUp).Row 'numero de la dernière ligne Set Maplage = .Range("A6:J" & derniereligne) 'plage dans le tableau ou il y a des données Maplage.AutoFilter Field:=1, Criteria1:="<>" 'filtrer sur les lignes non vides For Each Cell In Maplage If Cell.Interior.ColorIndex = 3 Then ' /!\ couleur gris clair excel 2003 ????? Cell.SpecialCells(xlCellTypeVisible).Cut Destination:=Worksheets("Synthèse").Range("A" & LigneDestinationSurFeuilMacro) 'couper/coller LigneDestinationSurFeuilMacro = Worksheets("Synthèse").Range("A" & .Columns("A").Rows.Count).End(xlUp).Row + 1 'la prochaine ligne de destination 'sera la ligne d'en dessous. Maplage.AutoFilter 'enlever le filtre End If Next End If End With Next End Sub
derniereligne = .Range("A" & .Rows.Count).End(xlUp).Row
déjà :
si tu avais lu attentivement le lien donné, tu saurais (entre autres) quederniereligne = .Range("A" & .Rows.Count).End(xlUp).Row
sauf que quand je fais ça il me met une erreur .Rows.. avec "erreur de compilation" encore..
Private Sub CommandButton1_Click() With Worksheets("Feuil1") derniereligne = .Range("B" & .Rows.Count).End(xlUp).Row End With MsgBox derniereligne End Sub
Sub SUPPR() Dim Cell As Range, derniereligne As Long, Maplage As Range Dim Feuille As Worksheet Dim LigneDestinationSurFeuilMacro As Long LigneDestinationSurFeuilMacro = Worksheets("Synthèse").Range("A" & .Rows.Count).End(xlUp).Row 'commencer à la première ligne vide For Each Feuille In ThisWorkbook.Worksheets ' Pour chaque feuille de ce fichier With Feuille If .Range("A2").Value = "Légende" Then ' prendre seulement les onglet agent derniereligne = .Range("A" & .Rows.Count).End(xlUp).Row 'numero de la dernière ligne Set Maplage = .Range("A6:J" & derniereligne) 'plage dans le tableau ou il y a des données Maplage.AutoFilter Field:=1, Criteria1:="<>" 'filtrer sur les lignes non vides For Each Cell In Maplage If Cell.Interior.ColorIndex = 3 Then ' /!\ couleur gris clair excel 2003 ????? Cell.SpecialCells(xlCellTypeVisible).Cut Destination:=Worksheets("Synthèse").Range("A" & LigneDestinationSurFeuilMacro) 'couper/coller LigneDestinationSurFeuilMacro = Worksheets("Synthèse").Range("A" & .Rows.Count).End(xlUp).Row + 1 'la prochaine ligne de destination 'sera la ligne d'en dessous. Maplage.AutoFilter 'enlever le filtre End If Next End If End With Next End Sub