Déplace la cellule active d'une ligne vers le bas et deux colonnes vers la droite

Sub DéplaceCellActive()
Dim LigVar, ColVar
LigVar = 1
ColVar = 2
Selection.Offset(LigVar, ColVar).Select
End Sub

Sélectionne la cellule F1 et "scroll" l'écran

Sub SelectCell()
Application.GoTo Reference:=ActiveSheet.Range("F1"), Scroll:=True
End Sub

Ajuste la colonne

Sub ajuste_colonne()
Selection.Columns.AutoFit
End Sub

Sub Redefini_Selection()
Range("MySelect").Resize(rowsize:=1, columnsize:=5).Select
End Sub

Sub SelectionLigne()
Range("MySelect").EntireRow.Select
End Sub

Sub SelectionZone_1ere()
With Range("A1").CurrentRegion
Union(.Cells, .Offset(0, 1)).Select
End With
End Sub

Sub SelectionZone_2eme()
With Range("A1").CurrentRegion
.Resize(, .Columns.Count + 1).Select
End With
End Sub

Sub DétruireLigne()
derniereLigne = ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
For r = derniereLigne To 1 Step -1
If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete
Next r
End Sub

Sub DétruireLignesiC()
derniereLigne = ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
For r = derniereLigne To 1 Step -1
If IsEmpty(Range("C" & r)) Then Rows(r).Delete
Next r
End Sub

Sub DeletesiCvide2()   'plus rapide
With Range("C1", Range("A65000").End(xlUp)). _
SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub

Efface la ligne de la cellule active de valeur 0 d'une plage de cellule

Sub EffaceLigneVide()
Range("D2").Select

'Sélection de la cellule de départ avec décalage sur les lignes(Offset(1,0))

Sub SupLigValeur()
Dim Var
Dim NumLg
On Error Resume Next
Var = InputBox(Prompt:="Taper la valeur recherchée. ")
Cells.Find(What:=(Var), After:=ActiveCell,LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder _
:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Activate
With Application.ActiveCell
NumLg = .Row
End With
ActiveCell.EntireRow.Select
Style = vbYesNo + vbDefaultButton1
Msg = "Suppression de la ligne N°: " & NumLg
Title = "Attention suppression de la ligne."
Réponse = MsgBox(Msg, Style, Title)
If Réponse = vbYes Then
Selection.Delete Shift:=xlUp
Else
Exit Sub
End If
End Sub

Sub RechercheMot()
Dim Var As String
On Error Resume Next
Var = InputBox("Mot à rechercher ?", , "zzzz")
'pour ne rien supprimer en cas d' ECHAP ou D'ANNULER
If Var = "" Then Exit Sub
Set MotTrouvé = Cells.Find(What:=Var)
If Not MotTrouvé Is Nothing Then
MotTrouvé.Select
'confirmation de suppression
Style = vbYesNo + vbDefaultButton1
Msg = "Suppression de la ligne"
Title = "Attention suppression de la ligne."
Réponse = MsgBox(Msg, Style, Title)
If Réponse = vbYes Then
ActiveCell.EntireRow.Select
Selection.Delete Shift:=xlUp
End If
Else
MsgBox "Rien trouvé"
Exit Sub
End If
[A1].Select
End Sub

Teste si les cellules de la plage sont vides ou non vides et entre la formule indiquée dans la première cellule vide testée.

Sub Parcourir()
Range("A1:A20").Activate
En_Colonne = ActiveCell.Column
En_Ligne = ActiveCell.Row + 1
While Not IsEmpty(ActiveCell.Value)
Cells(En_Ligne, En_Colonne).Activate
En_Ligne = En_Ligne + 1
Wend
With ActiveCell
ActiveCell.FormulaR1C1 = "Premiere cellule vide"
Range("A11").Select
End With
End Sub

Compare les valeurs de 2 plages de cellules(Votant et Resultat)

Sub TestRésultat()
Dim CellPtr
Dim X
Dim Z
Worksheets("Résultats").Select
Set X = Range("Votant")
Set Z = Range("Résultat")
Z.Select
Selection.Interior.ColorIndex = xlNone
For CellPtr = 1 To X.Count
If X(CellPtr) = Z(CellPtr) Then
Z(CellPtr).Select
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
End If
Next CellPtr
Z.Select
If Selection.Interior.ColorIndex = 15 Then
MsgBox Prompt:="La plage Votant et la plage Résultat sont identiques. Il n'y a pas d'erreur."
Range("A1").Select
Else
Msg = " Vous devez corriger l'erreur ! "
Style = vbCritical
Title = " <<< Erreur trouvée >>>"
Réponse = MsgBox(Msg, Style, Title, Help, Context)
If Réponse = vbYes Then
Z.Select
End If
End If
End Sub

Colore en gris toutes les cellules dont les valeurs sont <30 de la plage E2:E65

Sub StockInf50()
For Each Cell In Range("E2:E65")
If Cell.Value < 30 Then
Cell.Select
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
End If
Next
End Sub

Sub 1ereLettremajuscule()
phrase = Selection.Value
phrase = UCase(Left(phrase, 1)) + Right(phrase, Len(phrase) - 1)
Selection.Value = phrase
End Sub

Mets en majuscule toute la phrase de la sélection

Sub MinusculeMajuscule()
Dim MotsCellule As String
MotsCellule = Selection.Value
MotsCellule = UCase(MotsCellule)
Selection.Value = MotsCellule
End Sub

Mets en minuscule toute la phrase de la sélection

Sub MajusculeMinuscule()
Selection = Evaluate("transpose(lower(transpose(" & Selection.Address & ")))")
End Sub

Fait la somme des chiffres écrits en rouge de la sélection

Sub sommeCouleurRougeText()
Dim Cellule As Range
Dim total  As Variant
For Each Cellule In Selection
If Cellule.Font.ColorIndex = 3 Then

'3 rouge et 1 pour le noir

'If Cellule.Interior.ColorIndex = 3 Then (pour la couleur de fond)

If IsNumeric(Cellule) Then total = total + Cellule.Value
End If
Next
MsgBox total
Range("G12") = total
End Sub

Compte le nombre de cellules colorées en rouge de la sélection

Sub NombredeCellRouge()
Dim Cellule As Range
Dim total  As Variant
For Each Cellule In Selection
If Cellule.Interior.ColorIndex = 3 Then 'rouge
total = total + Cellule.Count
End If
Next
MsgBox "Il y a " & total & " Cellules rouges"
Range("A1") = total
End Sub

Personnalise les couleurs de la sélection suivant les valeurs RGB

Sub CouleurRGB()
Range("a1").Interior.Color = RGB(0, 0, 0)
Range("a2").Interior.Color = RGB(255, 0, 0)
End Sub

Cherche si la sélection contient une formule

Sub ChercheFormule()

'Dès qu'une formule est trouvée,
'un message s'affiche et sort de la boucle.

For Each Cellule In Range("A1:B5")
If Left(Cellule.Formula, 1) = "=" Then
MsgBox "La plage contient une formule."
Exit For
End If
Next
End Sub

Trie les lignes et supprime les doublons.

Sub tridoublon()
Worksheets("Feuil1").Range("A1").Sort _
key1:=Worksheets("Feuil1").Range("A2"), _
Order1:=xlAscending, Header:=xlGuess

Set MaCell = Worksheets("Feuil1").Range("A1")

Do While Not IsEmpty(MaCell)
Set MaCellSuite = MaCell.Offset(1, 0)
If MaCellSuite.Value = MaCell.Value Then
MaCell.EntireRow.Delete
End If
Set MaCell = MaCellSuite

Loop
End Sub

Insére un commentaire dans une cellule.

Sub InsertionComment()
Dim MyCmt As String
Dim LaCell As Range

Set LaCell = Application.InputBox("Cliquez sur une cellule", Default:=ActiveCell.Address, Type:=8)
MyCmt = InputBox("Inscrivez votre commentaire")
On Error Resume Next

With LaCell
.AddComment
With .Comment
.Visible = True
.Text Text:=MyCmt
End With
End With
End Sub

Formatage de tous les commentaires.

Sub FormatCommentaire()
Dim wks As Worksheet, MyCmt As Comment

For Each wks In Worksheets
For Each MyCmt In wks.Comments
MyCmt.Shape.OLEFormat.Object.AutoSize = True

With MyCmt.Shape.OLEFormat.Object.Font
.Name = "Verdana"
.Size = 10
.ColorIndex = 9
.Bold = True
End With

MyCmt.Shape.OLEFormat.Object.ShapeRange.Fill.ForeColor.SchemeColor = 35
Next MyCmt
Next wks
End Sub

Masque (affiche) tous les commentaires.

Sub MSQCommentaire()
Dim wks As Worksheet, MyCmt As Comment

For Each wks In Worksheets
For Each MyCmt In wks.Comments
    MyCmt.Visible = False   ' Masque le commentaire
    MyCmt.Visible = True   ' Affiche le commentaire
Next MyCmt
Next wks
End Sub

Masque (affiche) tous les commentaires. XP

Sub MsqXP()
Application.DisplayCommentIndicator = xlCommentIndicatorOnly
End Sub

Sub AffXP()
Application.DisplayCommentIndicator = xlCommentAndIndicator
End Sub

Supprime le nom utilisateur des commentaires

Sub SupNomAuthor()
Dim NomAuthor As String
Dim TxtComment As String
Dim Commentaire As Comment

'Recupere le nom utilisateur

NomAuthor = ActiveWorkbook.BuiltinDocumentProperties(3)

For Each Commentaire In ActiveSheet.Comments
TxtComment = Commentaire.Text
If Left(TxtComment, Len(NomAuthor)) = NomAuthor Then

'+2 pour virer les 2 points ":"

TxtComment = Mid(TxtComment, Len(NomAuthor) + 2)

'Chr(10) pour virer la ligne vide

If Left(TxtComment, 1) = Chr(10) Then
TxtComment = Mid(TxtComment, 3)
End If
End If
Commentaire.Text Text:=TxtComment
Next Commentaire
End Sub