Inserer des séparations dans une feuille
Bonjour,
j'ai inséré ce code dans une feuille je voudrais en colonne D inserer des sépartions par fournisseus mais je n'arrire pas a adapter ce code je demande donc votre aide je joins un fichier test
Sub separation_jours()
Dim DerLig As Long, i As Long, Mem As Long
Dim Flag As Boolean
With Worksheets("Achats_Jours") 'A adapter
DerLig = .Range("D" & .Rows.Count).End(xlUp).Row
For i = DerLig To 2 Step -1
If Cells(i, 23) > 0 Then Flag = True
If .Cells(i, 4) <> "" And .Cells(i - 1, 4) <> "" Then
If .Cells(i, 4) <> .Cells(i - 1, 4) And Flag Then
.Rows(i).Insert Shift:=xlDown
Mem = i
.Rows(i).RowHeight = 8 'HAUTEUR DE LA LIGNE NOIRE
.Range(.Cells(i, 2), .Cells(i, 4)).Interior.ColorIndex = 1
.Range(.Cells(i, 23), .Cells(i, 24)).Interior.ColorIndex = 1
Flag = False
End If
End If
Next
.Rows(Mem).Delete
End With
'****************************************************
' PERMET DE METTRE LA COLONNE C EN GRAS LE 13-09-2012
'****************************************************
Columns("C:C").Select
Selection.Font.Bold = True
'*******************************************
' ENLEVE LE FILTRE AUTOMATIQUE LE 13-09-2012
'*******************************************
Range("D1").Select
Selection.AutoFilter
'*****************************************
' CENTRE LE TITRE CELLULE D1 LE 13-09-2012
'*****************************************
Range("D1").Select
With Selection
.HorizontalAlignment = xlCenter
End With
End Submerci d'avance pour vos réponses
Cordialement
Bonsoir,
j'ai essayé de modifier le code mais sa ne donne pas encore de bon résultat
Sub separation_jours()
'**********************************
'EMPECHE LE DÉFFILEMENT INTEMPESTIF
'**********************************
Application.ScreenUpdating = False
Dim DerLig As Long, i As Long, Mem As Long
Dim Flag As Boolean
With Worksheets("Achats_Jours") 'A adapter
DerLig = .Range("D" & .Rows.Count).End(xlUp).Row
For i = DerLig To 2 Step -1
If Cells(i, 24) > 0 Then Flag = True
If .Cells(i, 4) <> "" And .Cells(i - 1, 4) <> "" Then
If .Cells(i, 4) <> .Cells(i - 1, 4) And Flag Then
.Rows(i).Insert Shift:=xlDown
Mem = i
.Rows(i).RowHeight = 8 'HAUTEUR DE LA LIGNE NOIRE
.Range(.Cells(i, 2), .Cells(i, 4)).Interior.ColorIndex = 16 'changer 2 par 4
.Range(.Cells(i, 8), .Cells(i, 20)).Interior.ColorIndex = 16
.Range(.Cells(i, 22), .Cells(i, 24)).Interior.ColorIndex = 16
Flag = False
End If
End If
Next
.Rows(Mem).Delete
End With
' '****************************************************
' ' PERMET DE METTRE LA COLONNE C EN GRAS LE 13-09-2012
' '****************************************************
' Columns("C:C").Select
' Selection.Font.Bold = True
' '*******************************************
' ' ENLEVE LE FILTRE AUTOMATIQUE LE 13-09-2012
' '*******************************************
' Range("D1").Select
' Selection.AutoFilter
' '*****************************************
' ' CENTRE LE TITRE CELLULE D1 LE 13-09-2012
' '*****************************************
' Range("D1").Select
' With Selection
' .HorizontalAlignment = xlCenter
' End With
End SubCordialement
Bonjour
en plus de faire des séparations j'ai besoin aussi de les enlever pour faire des filtres sur les fournisseurs j'ai essayé ce code sur un bouton et cela m'efface toute les lignes vides et moi je voudrais juste supprimer les séparation je joins un nouveau fichier
Private Sub CommandButton1_Click()
' désactiver le rafraîchissement de l'écran pour accélérer le traitement
Application.ScreenUpdating = False
' désactiver les alertes pour empêcher l'affichage
' des messages du genre "Voulez-vous etc."
Application.DisplayAlerts = False
' se placer sur la dernière ligne contenant des données
Range("A65536").End(xlUp).Select
Do
If IsEmpty(ActiveCell) Then
ActiveCell.EntireRow.Delete
End If
ActiveCell.Offset(-1, 0).Select
Loop Until ActiveCell.Row = 1
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Submerci pour vos réponses
cordialement
bonjour,
avec ce code ça enlève les séparations mais le calcul est assez long pour enlever juste des lignes vides
Range("A4:A10000").SpecialCells(xlCellTypeBlanks).EntireRow.Deletecordialement
Bonjour
J'ai regardé tes fichiers et je cherche encore le problème
Chez moi cela fonctionne : c'est relativement rapide : < 1 seconde
Bonjour,
merci pour ta réponse je joins un fichier dans l'état actuel ou j'ai réussi à le faire fonctionner pour mettre les séparateurs c'est rapide
pour les enlever il fait comme une recherche et ensuite il efface les lignes vides d'ailleurs je n'arrive pas a mettre en couleur les cellules des séparateurs H,K,L,M,O,P,S,T pourrais-tu m'aider sur ce point j'ai oublié de dire que je suis sur Excel 2003
Merci
Cordialement
Bonjour
Tes mises en formes conditionnelles ont été faites avec XL 2007 ou +
A tester
Bonjour,
Merci pour ta réponse
le fichier c'est une histoire compliqué
au départ fait avec Excel 2003
changement d'Excel au travail 2003 en Excel 2010 donc beaucoup d'incompatibilités
retravaillé à la maison sur Excel 2007 mais là j'ai réinstallé Excel 2003 à la maison
pour revenir à ta réponse tout fonctionne bien j'ai plus qu'a l'adapter sur mon fichier original si j'y arrive parce que si tu voyais le code du fichier tu verrais que c'est pas du tout optimisé la plupart sont des macros Excel enregistrées mais j'ai pas eu le choix il a fallu que je me débrouille tous seul
une petite parenthèse est il possible de supprimer le format de la ligne ajoutée pour ensuite mettre la couleur 16
Cordialement
Bonjour,
Un grand merci a toi Banzai64 pour ton aide
ouf réussi a incorporer les routines dans le fichier original et dans ce code suivant (qui permet d'ajouter les séparateurs)serai t'il possible de supprimer les bordures de la ligne ajoutée
Sub separation_jours()
'**********************************
'EMPECHE LE DÉFFILEMENT INTEMPESTIF
'**********************************
Application.ScreenUpdating = False
'******************************************
'ROUTINE MODIFIER POUR ESSAIE LE 20-10-2013
'******************************************
Dim DerLig As Long, i As Long, Mem As Long
Dim Flag As Boolean
With Worksheets("Achats_Jours") 'A adapter
DerLig = .Range("D" & .Rows.Count).End(xlUp).Row
For i = DerLig To 2 Step -1
If Cells(i, 24) > 0 Then Flag = True
If .Cells(i, 4) <> "" And .Cells(i - 1, 4) <> "" Then
If .Cells(i, 4) <> .Cells(i - 1, 4) And Flag Then
.Rows(i).Insert Shift:=xlDown
Mem = i
' PEUT ETRE ICI POUR SUPPRIMER LES BORDURES
.Rows(i).RowHeight = 4 'HAUTEUR DE LA LIGNE NOIRE
.Range(.Cells(i, 2), .Cells(i, 24)).Interior.ColorIndex = 1 'couleur de la ligne 20-10-2013
Flag = False
End If
End If
Next
.Rows(Mem).Delete
End With
End Submerci d'avance pour vos réponses
Cordialement
Bonsoir
Utilises la même méthode que celle pour enlever la mise ne forme conditionnelle
With .Rows(i)
.Insert
.Offset(-1, 0).FormatConditions.Delete
.Offset(-1, 0).Borders.LineStyle = xlNone
End WithBonsoir
Excuse moi je ne vois pas ou mettre le code que tu m'as donné
Sub separation_jours()
'**********************************
'EMPECHE LE DÉFFILEMENT INTEMPESTIF
'**********************************
Application.ScreenUpdating = False
'******************************************
'ROUTINE MODIFIER POUR ESSAIE LE 20-10-2013
'******************************************
Dim DerLig As Long, i As Long, Mem As Long
Dim Flag As Boolean
With Worksheets("Achats_Jours") 'A adapter
DerLig = .Range("D" & .Rows.Count).End(xlUp).Row
For i = DerLig To 2 Step -1
If Cells(i, 24) > 0 Then Flag = True
If .Cells(i, 4) <> "" And .Cells(i - 1, 4) <> "" Then
If .Cells(i, 4) <> .Cells(i - 1, 4) And Flag Then
.Rows(i).Insert Shift:=xlDown
Mem = i
' PEUT ETRE ICI POUR SUPPRIMER LES BORDURES
' COMME CECI
With .Rows(i)
.Insert
.Offset(-1, 0).FormatConditions.Delete
.Offset(-1, 0).Borders.LineStyle = xlNone
End With
.Rows(i).RowHeight = 4 'HAUTEUR DE LA LIGNE NOIRE
.Range(.Cells(i, 2), .Cells(i, 24)).Interior.ColorIndex = 1 'couleur de la ligne 20-10-2013
Flag = False
End If
End If
Next
.Rows(Mem).Delete
End With
End Submerci
Cordialement
Bonjour
La macro du fichier que j'ai (quelques commentaires enlevés - tu les trouveras dans le fichier que j'ai posté précédemment)
Sub separation_jours()
'**********************************
'EMPECHE LE DÉFFILEMENT INTEMPESTIF
'**********************************
Application.ScreenUpdating = False
Dim DerLig As Long, i As Long, Mem As Long
Dim Flag As Boolean
With Worksheets("Achats_Jours") 'A adapter
DerLig = .Range("D" & .Rows.Count).End(xlUp).Row
For i = DerLig To 2 Step -1
If Cells(i, 24) > 0 Then Flag = True
If .Cells(i, 4) <> "" And .Cells(i - 1, 4) <> "" Then
If .Cells(i, 4) <> .Cells(i - 1, 4) And Flag Then
With .Rows(i)
.Insert
.Offset(-1, 0).FormatConditions.Delete
.Offset(-1, 0).Borders.LineStyle = xlNone
End With
Mem = i
.Rows(i).RowHeight = 8 'HAUTEUR DE LA LIGNE NOIRE
.Range(.Cells(i, 2), .Cells(i, 24)).Interior.ColorIndex = 16 'changer 2 par 4
Flag = False
End If
End If
Next
.Rows(Mem).Delete
End With
End SubBonsoir,
il reste les bordures du haut et bas des cellule H L O S sinon tout est parfais encore merci de ton aide
Cordialement
Bonsoir
J'ai rajouté ceci et ca a l'air ok
'.Offset(-1, 0).Borders.LineStyle = xlNone J'AI MIS CECI EN COMMENTAIRE
.Offset(-1, 0).Borders(xlDiagonalDown).LineStyle = xlNone
.Offset(-1, 0).Borders(xlDiagonalUp).LineStyle = xlNone
.Offset(-1, 0).Borders(xlEdgeLeft).LineStyle = xlNone
.Offset(-1, 0).Borders(xlEdgeTop).LineStyle = xlNone
.Offset(-1, 0).Borders(xlEdgeBottom).LineStyle = xlNone
.Offset(-1, 0).Borders(xlEdgeRight).LineStyle = xlNone
.Offset(-1, 0).Borders(xlInsideVertical).LineStyle = xlNone
.Offset(-1, 0).Borders(xlInsideHorizontal).LineStyle = xlNoneCordialement
bonsoir
une toute petite dernière question
comment fusionner toutes les cellules (ici grises) de la ligne ajoutée
Cordialement
Bonjour
Je trouve bizarre que tu as été obligé de passer par la suppression de toutes les bordures
Mais bon le principal c'est que cela fonctionne
Pour fusionner les cellules
rajoutes
End With
Mem = i
.Rows(i).RowHeight = 8 'HAUTEUR DE LA LIGNE NOIRE
.Range(.Cells(i, 2), .Cells(i, 24)).Interior.ColorIndex = 16 'changer 2 par 4
.Range(.Cells(i, 2), .Cells(i, 24)).Merge
Flag = False
End If
End If
Next
.Rows(Mem).Delete
End With
End SubBonsoir,
je les enlèves car il y a des bordures blanche au milieu et visuellement ce n'est pas terrible ensuite je les fusionnes (j'en profite pour te remercier de prendre de ton temps pour régler mon problème) pour mettre une bordure autour des cellules fusionnées comme ça les séparations seront visuellement claire
Cordialement
Bonjour
essayes cette macro
Sub separation_jours()
Application.ScreenUpdating = False
Dim DerLig As Long, i As Long, Mem As Long
Dim Flag As Boolean
With Worksheets("Achats_Jours") 'A adapter
DerLig = .Range("D" & .Rows.Count).End(xlUp).Row
For i = DerLig To 2 Step -1
If Cells(i, 24) > 0 Then Flag = True
If .Cells(i, 4) <> "" And .Cells(i - 1, 4) <> "" Then
If .Cells(i, 4) <> .Cells(i - 1, 4) And Flag Then
With .Rows(i)
.Insert
.Offset(-1, 0).FormatConditions.Delete
End With
Mem = i
.Rows(i).RowHeight = 8 'HAUTEUR DE LA LIGNE NOIRE
With .Range(.Cells(i, 2), .Cells(i, 24))
.Interior.ColorIndex = 16 'changer 2 par 4
.Merge
.BorderAround Weight:=xlThin
End With
Flag = False
End If
End If
Next
.Rows(Mem).Delete
End With
End SubBonsoir,
Je voulais te remercier pour ton aide très précieuse Banzai64
Cordialement