Macro mal écrite

[Fabien]

Bonjour
Est ce que quelqu'un peut m'aider à mieux l'écrire, car quand je m'en sert mon fichier augmente en taille d'une facon importante
Merci

Sub SupprimeJoueur()
'déprotéger feuille
With ActiveSheet
.EnableSelection = xlNoRestrictions
.Unprotect Password:="Milou"
'positionner en fin de tableau
Cells.Find(What:="FinTab", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False).Activate
'sélection des deux lignes au dessus et efface
ActiveCell.Offset(-2, 0).Rows("1:2").EntireRow.Select
Selection.Delete Shift:=xlUp
'positionner en fin de tableau
Cells.Find(What:="FinTab", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False).Activate
'sélection de la zone pour refaire les bordures
ActiveCell.Offset(-2, 0).Range("C1:W1,Y1:Z1,AB1:AC1").Select
'Bordures
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
'positionner de la fin du demi tableau
Cells.Find(What:="FinDTab", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False).Activate
'sélection des deux lignes au dessus et efface
ActiveCell.Offset(-2, 0).Rows("1:2").EntireRow.Select
Selection.Delete Shift:=xlUp
'positionner de la fin du demi tableau
Cells.Find(What:="FinDTab", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False).Activate
'sélection de la zone pour refaire les bordures
ActiveCell.Offset(-2, 0).Range("C1:W1,Y1:Z1,AB1:AC1").Select
'Bordures
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
'positionner de la fin de tableau
Cells.Find(What:="FinTab", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False).Activate
'Sélection de toutes les lignes sauf les 4 qui suivent mon repère
ActiveCell.Offset(4, 0).Rows("1:65536").EntireRow.Select
Selection.EntireRow.Hidden = True
'Protège feuille
.EnableSelection = xlNoSelection
.Protect Password:="Milou", Contents:=True, UserInterfaceOnly:=True, Scenarios:=True
End With

End Sub

PS Rows("1:65536") fait planter ma macro, comment finou derniere au lieu 65536

Merci

 

[Berkane]

Salut,

Essai ceci:

1-sélectionne tout ton code
2-Ctrl + C (Copier)
3-Suppr
4-Ctrl + V (Coller)
5-enregistre
6-Regarde la taille
7-Réponds-moi pour me dire ce qu'il en est

@+

 

[fodjio]

Salut!

On voit que t'as appris le VBA avec l'enregistreur de macro!
Cependant il a une fâcheuse tendance à beaucoupo alourdir le code pour du vent!

J'ai éclairecis du mieux que j'ai pu, je l'ai pas testé mais j'espère que t'aura compris le principe qui dit :
Supprime les "Select", "Activate", et autres "Selection" autant que tu le peux (sauf si tu veux vraiment selectionner un objet)
Sub SupprimeJoueur() et utilise des variables.

Dim cellule as Range
dim plage as Range

'déprotéger feuille
With ActiveSheet
.EnableSelection = xlNoRestrictions
.Unprotect Password:="Milou"
'positionner en fin de tableau
Set cellule=Cells.Find(What:="FinTab", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False)
'sélection des deux lignes au dessus et efface
cellule.Offset(-2, 0).Rows("1:2").EntireRow.Delete Shift:=xlUp
'positionner en fin de tableau
Set cellule=Cells.Find(What:="FinTab", After:=cellule, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False)
'sélection de la zone pour refaire les bordures
Set plage=cellule.Offset(-2, 0).Range("C1:W1,Y1:Z1,AB1:AC1")
With plage
'Bordures
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
End With
'positionner de la fin du demi tableau
Set cellule=Cells.Find(What:="FinDTab", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False)
'sélection des deux lignes au dessus et efface
Set plage=cellule.Offset(-2, 0).Rows("1:2").EntireRow.Delete Shift:=xlUp
'positionner de la fin du demi tableau
Set cellule=Cells.Find(What:="FinDTab", After:=cellule, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False)
'sélection de la zone pour refaire les bordures
Set plage=cellule.Offset(-2, 0).Range("C1:W1,Y1:Z1,AB1:AC1")
'Bordures
With plage
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
End With
'positionner de la fin de tableau
Set cellule=Cells.Find(What:="FinTab", After:=cellule, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False)
'Sélection de toutes les lignes sauf les 4 qui suivent mon repère
cellule.Offset(4, 0).Rows("1:65536").EntireRow
cellule.EntireRow.Hidden = True
'Protège feuille
.EnableSelection = xlNoSelection
.Protect Password:="Milou", Contents:=True, UserInterfaceOnly:=True, Scenarios:=True
End With

End Sub


Bonne chance

 

[Fabien]

Merci fodjio

mais ta macro ne fonctionne pas
sinon je pense avoir cibler ce qui augmente la taille de mon fichier,c'est la fonction qui masque les lignes, je pense???

cellule.Offset(4, 0).Rows("1:65536").EntireRow
cellule.EntireRow.Hidden = True

Peut on écrire 65536 autrement

Merci A+