Sub JourSemaine()
Dim semaine(1 To 7) As String
semaine(1) = "Lundi"
semaine(2) = "Mardi"
semaine(3) = "Mercredi"
semaine(4) = "Jeudi"
semaine(5) = "Vendredi"
semaine(6) = "Samedi"
semaine(7) = "Dimanche"
For i = 1 To 7
Selection.Offset(i - 1, 0).Formula = semaine(i)
Next i
End Sub

Crée un tableau Année - Trimestre (Sélectionner une cellule)

Sub TableauAnTrimestre()
For An = 1 To 5
Cells(1, An + 1).Value = 2000 + An
Next An
For Trimestre = 1 To 4
Cells(Trimestre + 1, 1).Value = "Trim" & Trimestre
Next Trimestre
End Sub

Ajoute la chaîne de caractères "Terminé" à la fin du texte de la cellule

Sub InserTermineDansCellule()
Cells(1, 1).Select
With Selection
.Characters(.Characters.Count + 1).Insert (" terminé")
End With
End Sub

Associe 2 plages en un seul objet avec la méthode UNION

Sub UniondePlage()
Dim plg1, plg2, ToutePlage As Range

Set plg1 = Sheets("Feuil1").Range("A1:A10")
Set plg2 = Sheets("Feuil1").Range("B10:B20")
Set ToutePlage = Union(plg1, plg2)

ToutePlage.Interior.ColorIndex = 5
End Sub

Sub RempliUnion()
Worksheets("Feuil1").Activate
Set MaPlage = Application.Union(Range("A1:D10"), Range("F1:H12"))
MaPlage.Value = 100
End Sub

Sélectionne la cellule A154 de la Feuil1 et "Scroll" l'écran

Sub AllerA()
Application.Goto Reference:=Worksheets("Feuil1").Range("A154"), Scroll:=True
End Sub

Sub NumeroDeLigne()
NumeroLigne = Cells.Find("100").Row
MsgBox NumeroLigne
End Sub

Sub NombreDeLigne()
With Selection
MsgBox Selection.Rows.Count
End With
End Sub

Sub ModifFormule()
Application.SendKeys "{f2}"

'Envoie la touche F2

For I = 1 To 10

'Boucle pour mettre le curseur à gauche

Application.SendKeys "{gauche}"
Next I
Application.SendKeys "{droite}"

'Pour écrire à droite du signe =

Application.SendKeys "{P}{r}{i}{x}{.}{x}{l}{s}{!}"
Application.SendKeys "{ENTREE}"

'Valide la formule

End Sub

Il faut savoir que:
Pour afficher une formule il faut entrer un espace ou une apostrophe (') devant la formule.
Cette macro affiche la formule A1 en A2

Sub AfficheFormule()
Range("A1").Select
Selection.Copy
Range("A2").Select
Selection.PasteSpecial Paste:=xlFormulas, Operation:=xlNone,
SkipBlanks:= False, Transpose:=False

Application.SendKeys "{f2}"

For I = 1 To 10
Application.SendKeys "{gauche}"
Next I

Application.SendKeys "{droite}"

'inscrit un espace devant la formule

Application.SendKeys "{BS}"
Application.SendKeys "{ENTREE}"
End Sub

Affiche et sélectionne la référence d'une sélection

Sub BoiteSelectionZone()
Dim Var As Object
On Error Resume Next
Set Var = Application.InputBox(Prompt:="Sélectionner votre zone: (Ex. A1:B10) ", _
Title:="Sélection de zone ", Default:="$A$1", Type:=8)
On Error GoTo 0
If Not (TypeName(Var) = "Rien") Then
MsgBox Var.Address
Var.Select
End If
Set Var = Nothing
End Sub

Donne le numéro de ligne aussi que la lettre de la colonne de la cellule active

Sub ColLigne()
Colonne = Left$(ActiveCell.Address(0, 0), (ActiveCell.Column < 27) + 2)
Ligne = ActiveCell.Row
MsgBox Colonne & Ligne
MsgBox Colonne
MsgBox Ligne
End Sub

Mode d'emploi:
Dans l'éditeur VB double-cliquez sur la feuille désirée
et coller tout le code suivant dans la partie droite.
Modifiez la plage si besoin ici ----Intersect(Target, Range("A1:A10"))----
A chaque modification des cellules de la plage (A1:A10) le format est mis automatiquement.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Plage As Range
Set Plage = Intersect(Target, Range("A1:A10"))
If Plage Is Nothing Then Exit Sub
For Each cellule In Plage
If cellule.Value = 1 Then
cellule.NumberFormat = "General"" er"""
Else: cellule.NumberFormat = "General"" ème"""
End If
Next
End Sub

D'autres procédures événementielles.

Pour la feuil1

Private Sub Worksheet_Activate()
MsgBox "La Feuil1 est activée"
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
MsgBox "DoubleClick effectué"
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
MsgBox "Click droit effectué"
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
MsgBox "La valeur a changée"
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
MsgBox "La sélection a changé"
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
MsgBox "DoubleClick interdit!"
Cancel = True
End Sub

event.zip   13 ko  Des exemples simples de procédures événementielles.

Sub SearchText()
Dim SearchString, SearchChar, MyPos
SearchChar = "salut"
For Each cell In Range("A1:A11")
SearchString = cell.Text
MyPos = InStr(SearchString, SearchChar)

If MyPos > 0 Then
MsgBox ("Mot trouvé")
MsgBox "Mot trouvé à cette adresse: " & cell.Address
cell(1, 2).Value = "(salut) est sur cette ligne"
End If
Next
End Sub

Sub RecupValeur()
Dim Val1
'Dim Resultat As Integer (pour un résultat en entier)
Val1 = Sheets("Feuil1").[a1].Value
Resultat = Val1 * 10
Sheets("Feuil1").[a2].Value = (Resultat)
MsgBox "Opération effectuée." & Chr(13) & Chr(13) _
& "Résultat :" & CStr(Resultat)
End Sub

Copie la plage A1:A15, ajoute 1 et colle dans la plage C1:C15

Sub CopiUnePlagedeValeur()
Dim MaValeur, compteur
For compteur = 1 To 15
Range("A" & compteur).Select
MaValeur = ActiveCell.Value
Range("C" & compteur).Select
ActiveCell.Value = MaValeur + 1
Next
End Sub

Sub test_A()
Colonne = Left$(ActiveCell.Address(0, 0), (ActiveCell.Column < 27) + 2)
If Colonne = "A" Then
MsgBox "Je lance la macro ici"
Else
MsgBox Colonne
End If
End Sub

Somme des valeurs positives.

'avec somme.si:
'=SOMME.SI(A1:A10;">0")

'Avec une fonction matricielle: (CTRL MAJ ENTREE)
'{=SOMME(A1:A10*(A1:A10>0))}

Sub SommePositive()
For Each Cell In Range("A1:A10")
If Cell.Value > 0 Then
total = total + Cell
End If
Next
MsgBox "Total des valeurs positives " & total
Range("A11") = total
End Sub

Somme des valeurs négatives.

'avec somme.si:
'=SOMME.SI(A1:A10;"<0")

'Avec une fonction matricielle: (CTRL MAJ ENTREE)
' {=SOMME(A1:A10*(A1:A10<0))}

Sub SommeNégative()
For Each Cell In Range("A1:A10")
If Cell.Value < 0 Then
total = total + Cell
End If
Next
MsgBox "Total des valeurs négatives " & total
Range("A11") = total
End Sub

Sub a1txt()
Var = [A1]
FichierTXT = "C:\ajeter\aentxt.txt" 'à modifier
If Len(Dir(FichierTXT)) > 1 Then Kill FichierTXT
Open FichierTXT For Output As 1
Print #1, Var
Close
End Sub

Sub pourcentage()
Dim mycell, myvaleur, pourcent
pourcent = InputBox("Quel pourcentage appliquer?")
If IsNumeric(pourcent) Then
For Each mycell In Application.Selection.Cells
myvaleur = mycell.Value
If IsNumeric(myvaleur) Then
'teste si la cellule n'est pas vide ou contient une formule
If Not (IsEmpty(myvaleur) Or mycell.HasFormula) Then
mycell.Value = myvaleur * (pourcent / 100 + 1)
End If
End If
Next mycell
End If
End Sub

Sub Nodefil()
Feuil1.ScrollArea = "B4:H23"
End Sub

Sub Okdefil() ' pour libérer le défilement
Feuil1.ScrollArea = ""
End Sub

Sub CompteLesVides() Vide = 0
For Each Cellule In Selection.Cells
If IsEmpty(Cellule) Then Vide = Vide + 1
Next
MsgBox "Il y a " & Vide & " cellules vides dans la sélection"
End Sub

Et comment compter les non vides ? Il suffit d’ajouter l’opérateur Not de négation devant IsEmpty.

Sub CompteLesNonVides()
NonVide = 0
For Each Cellule In Selection.Cells
If Not IsEmpty(Cellule) Then NonVide = NonVide + 1
Next
MsgBox "Il y a " & NonVide & " cellules non vides dans la sélection"
End Sub

Sub TexteEnChiffre() Dim maZone As Range
Set maZone = Range("A1:" & Range("A100").End(xlUp).Address) 'Définit plage
maZone.Select
Dim unecellule As Object
For Each unecellule In Selection
valeur = ActiveCell.Value
If valeur = "" Then 'Saute cellules vides
GoTo suite
End If
valnum = CDbl(valeur) 'convertit texte en chiffre
unecellule.Value = valnum
suite:
ActiveCell.Offset(1, 0).Select
Next
End Sub

Sub totalColonne()
With Range("A1", [A:A].Find("*", [A1], , , , xlPrevious))
.Item(.Count + 1).Formula = "=SUM(" & .Address(0, 0) & ")"
End With
End Sub

Sub totaligne()
Dim maPlage As Range
Set maPlage = Range("A1", Cells(1, 256).End(xlToLeft))
Cells(1, 256).End(xlToLeft).Offset(0, 1) = Application.Sum(maPlage)
End Sub

Sub totaligne2()
For leslignes = 1 To 7 'pour plusieurs lignes( de 1 à 7 par exemple)
Dim maPlage As Range
Set maPlage = Range("A" & leslignes, Cells(leslignes, 256).End(xlToLeft))
Cells(leslignes, 256).End(xlToLeft).Offset(0, 1) = Application.Sum(maPlage)
Next
End Sub