Définir un champ
Range(champ)
Range permet de spécifier un champ.
Range("B3").Select
Range("D4,F4:G4,D116").Select
Range("D4,F4:G4,D116").Interior.ColorIndex=33
Cells(ligne,Colonne)
Cells(ligne,colonne) représente
la cellule qui est à l'intersection de ligne et de colonne.
Cells(3,2) représente le contenu de la cellule qui est à
l'intersection de la 3e ligne et de la 2e colonne.
Cells(3,2).Select
Range(champ).Cells(ligne,colonne)
La ligne et la colonne sont relatives au début du champ spécifié dans Range
Range("B3:D6").cells(1,1).select
Cellule active
ActiveCell
La cellule active se spécifie avec ActiveCell. Sur cet exemple, la variable X prend la valeur de la cellule active et va s’écrire en A1
x=ActiveCell.Value
Range("A1").Value=x
Positionner le curseur
Range(champ).Select sélectionne le champ spécifié
Range("B3").Select ' Sélectionne la cellule
B3
[B3].Select ' Sélectionne la cellule B3
Range("B3").Offset(1,0).select ' Déplace le curseur une
ligne au dessous de B3
Activecell.Offset(0,1).select
Déplacer le curseur
Activecell.Offset(nb_lignes,nb_colonnes).Select
Activecell.Offset(nb_lignes,nb_colonnes).Select déplace le curseur du nombre de lignes et de colonnes spécifiés.
Range("A1").Select 'Se
positionne en A1
ActiveCell.Offset(0; 1).Select 'se décale
à droite d’une cellule
ActiveCell.Offset(1; 0).Select ' Se décale
en bas d’une cellule
Masquer la mise à jour de l'écran
Application.ScreenUpDating=True/False
Application.ScreenUpdating=False désactive
la mise à jour de l'écran.
Application.ScreenUpdating=True la réactive.
Application.ScreenUpdating=False
....
....
Application.ScreenUpdating=True
Champ.End(xlDown-XlUp-XlToRight-XlToLeft)
champ.End(XlDown) représente:
- la dernière cellule d'un bloc de cellules pleines
d’une colonne (2 minimum) en déplaçant
le curseur vers le bas.
- ou la prochaine cellule pleine d'un bloc vide en déplaçant
le curseur vers le bas.
Range("A1").End(xlDown).Select
' positionne sur A4
Range("A1", [A1].End(xlDown)).Select ' sélectionne
A1:A4
Range("A4").End(xlDown).Select '
positionne sur A7
champ.End(XlUp) représente:
- la dernière cellule d'un bloc de cellules pleines
d’une colonne (2 minimum) en déplaçant
le curseur vers le haut.
- ou la prochaine cellule pleine d'un bloc vide en déplaçant
le curseur vers le haut.
Range("A7").End(xlUp).Select '
sélectionne A4
Range("A65000").End(xlUp).Select '
sélectionne A10
champ.End(XlToRight) et champ.End(XlToLeftt)
correspondent à un déplacement
vers la droite et vers la gauche.
Range("A1").End(xlToRight).Select ' sélectionne D1
Sélectionner la région courante
CurrentRegion
champ.CurrentRegion sélectionne les cellules autour du champ spécifié.
Range("A1").CurrentRegion.Select
' sélectionne
les cellules autour de A1
Range("A1").CurrentRegion.Resize(, 1).Select '
sélectionne la première colonne
Range("A1").currentregion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select ' Sauf
la première ligne
Range("A1").CurrentRegion.PrintPreview ' Aperçu
Range("A1").CurrentRegion.PrintOut ' Impression
Rédéfinir la taille d'un champ
Resize(lignes,colonnes)
Redéfinit la taille d'un champ.
Range("A1").Resize(1,4).Select ' sélectionne A1:D1
Range("A1").CurrentRegion.Select
Selection.Offset(1).Resize(Selection.Rows.Count - 1).Select ' enlève
la première ligne
Sélectionner les cellules particulières
Champ.SpecialCells(type,valeur)
-SpecialCells permet de sélectionner
des cellules particulières. C'est l'équivalent
de la commande Edition/Atteindre.
| SpecialCells(xlCellTypeBlanks) |
Cellules vides |
-Si type a la valeur xlCellTypeConstants ou xlCellTypeFormulas, valeur spécifie le type de cellules: nombre, texte,valeurs logiques, erreurs.
Cells.SpecialCells(xlLastCell).Select '
Sélectionne la dernière cellule de la feuille
Cells.SpecialCells(xlCellTypeConstants, 1).Select '
Sélectionne les cellules numériques de la feuille
Cells.SpecialCells(xlCellTypeConstants, 2).Select '
Sélectionne le texte de la feuille
Cells.SpecialCells(xlCellTypeConstants, 23).Select '
Sélectionne les constantes de la feuille
Range("A:A").SpecialCells(xlCellTypeConstants, 23).Select '
Sélectionne les constantes de la colonne A
Supprimer les lignes vides en colonne A
On Error Resume Next
Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Supprimer les cellules vides en colonne A
[A:A].SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
Copier les lignes non vides en colonne A sur un autre onglet
[A:A].SpecialCells(xlCellTypeConstants, 23).EntireRow.Copy Sheets(2).[A65000].End(xlUp).Offset(1, 0)
RAZ des zones déverrouillées
Sub raz()
ActiveSheet.Unprotect Password:="moi"
For Each c In Cells.SpecialCells(xlCellTypeConstants,
23)
If c.Locked = False Then c.Value = Empty
Next c
ActiveSheet.Protect Password:="moi"
ActiveSheet.EnableSelection = xlUnlockedCells
End Sub
Tri d'un champ lignes/colonnes
Sub TriTab2D()
Set f = Sheets("BD")
Set Rng = f.Range("A1").CurrentRegion
Rng.Offset(1).Resize(Rng.Rows.Count - 1, Rng.Columns.Count).Sort
key1:=Rng.Cells(2, 1), _
Order1:=xlAscending, Header:=xlNo, MatchCase:=False,
Orientation:=xlSortColumns
Rng.Offset(, 1).Resize(Rng.Rows.Count, Rng.Columns.Count -
1).Sort key1:=Rng.Cells(1, 2), _
Order1:=xlAscending, Header:=xlNo, MatchCase:=False,
Orientation:=xlSortRows
End Sub
Sélectionner la zone utilisée d'une feuille
UsedRange
Sélectionne la zone utilisée dans la feuille active.
ActiveSheet.UsedRange.Select
Adresse
MsgBox ActiveSheet.UsedRange.Address
Sélection de la dernière cellule
Range(Split(ActiveSheet.UsedRange.Address, ":")(1)).Select
Union et Intersection de champs
Union(champ1,Champ2,…)
Donne l'union de champ1,champ2,...
Union([A2:B2], [A4:B4]).Select
Union([A2:B2], [A4:B4]).Copy [A20]
Copie des cellules pleines de plusieurs champs dans un seul champ
Les cellules sont dans la même colonne:
Range("A1:A5,A10:A15").SpecialCells(xlCellTypeConstants, 23).Copy [D2]
Les cellules ne sont pas dans la même colonne:
i = 1
For Each c In Union([A3:B7], [C1:C5], [E3:E7]).SpecialCells(xlCellTypeConstants,
23)
i = i + 1
Cells(i, 7) = c
Next c
Sélectionne les cellules non verrouillées
Sub SelectNonVer()
Set champ = Nothing
For Each c In ActiveSheet.UsedRange
If Not c.Locked Then
If champ Is Nothing Then
Set champ = c
Else
Set champ = Union(champ,
c)
End If
End If
Next c
champ.Select
End Sub
Sub auto_open()
On Error Resume Next
CommandBars("BarreVer").Delete
Dim barre As CommandBar
Dim bouton As CommandBarControl
Set barre = CommandBars.Add(Name:="BarreVer")
barre.Visible = True
Set bouton = CommandBars("BarreVer").Controls.Add(Type:=msoControlButton)
bouton.Style = msoButtonCaption
bouton.OnAction = "SelectNonVer"
bouton.Caption = "Selection cellules non verrouillées"
End Sub
Ajout de listes
Sub AjoutListes()
[F2:F1000].ClearContents
Set champ = [A2].CurrentRegion.Offset(1)
For i = 1 To champ.Columns.Count
Range("F65000").End(xlUp).Offset(1).Resize(champ.Rows.Count)
= Application.Index(champ.Value, , i)
Next i
Définition d'un champ discontinu dynamique
On veut définir le champ B2:B5,D2:D5,F2:F5 de façon dynamique(on ne sait pas combien il y aura de colonnes)
A B C D E F
Values Valid Values Valid Values Valid
80 1
80 1
80 1
50 0 50
1 50
0
20 0 20
0 20
0
15 1 35
1 25
0
Private Sub Worksheet_Change(ByVal Target As Range)
Set champ = Range("b2:b5")
col = 4
Do While Cells(1, col) <> ""
Set champ = Union(champ, Cells(2, col).Resize(4,
1))
col = col + 2
Loop
If Not Intersect(Target, champ) Is Nothing And Target.Count
= 1 Then
Application.EnableEvents = False
If Target.Value = "Keep" Then
Target.Value = 1
If Target.Value = "No Keep" Then
Target.Value = 0
Application.EnableEvents = True
End If
End Sub
Autre exemple: on prend 1 colonne sur 2
Sub UnionDynamique()
Set plage = Range("A1:A4")
ncol = 10
h = plage.Count
intervalle = 2
For col = 1 + intervalle To ncol * intervalle Step intervalle
Set plage = Union(plage, Cells(1, col).Resize(h))
Next col
MsgBox plage.Address
MsgBox plage.Areas.Count
End Sub
Intersect(champ1,champ2,…)
Donne l'intersection de champ1,champ2,...
Renvoi Nothing si l'intersection ne comporte aucune cellule.
Intersect(Range("A2:D2"), Range("B1:C5")).Select
Rechercher une information
Find()
Champ.Find(What:=valeur,
After:=cellule, LookIn:=xlFormulas/XlValues,
LookAt:= xlPart/XlWhole,
SearchOrder:=xlByRows/XlByColumns,
SearchDirection:=xlNext/XlPrevious,
MatchCase:= True/False,
SearchFormat:=False)
Recherche un texte dans une champ. Find correspond à la commande Edition/Rechercher.
LookAt:= xlPart/XlWhole définit
si la comparaison se fait sur une partie ou la totalité de la cellule.
Par défaut, ce paramètre conserve la valeur
précédente.
LookIn:=xlFormulas/XlValues spécifie si la recherche se fait dans la formule ou le résultat. Par défaut, ce paramètre conserve la valeur précédente.
Exemple : On cherche un nom
Méthode 1 (gestion d'erreur)
Sub cherche()
nomCherche = InputBox("Nom cherché? ")
On Error Resume Next
Err = 0
Range("A2:A14").Find(What:=nomCherche, LookIn:=xlValues).Select
If Err = 0 Then
Range(ActiveCell, ActiveCell.End(xlToRight)).Select
Else
MsgBox "Pas trouvé"
End If
On Error GoTo 0
End Sub
Méthode 2
Sub cherche2()
nomCherche = InputBox("Nom cherché? ")
Set result = Range("A2:A14").Find(What:=nomCherche,
LookIn:=xlValues)
If result Is Nothing Then
MsgBox "Non trouvé"
Else
Range(result, result.End(xlToRight)).Select
End If
End Sub
Donne toutes les occurrences :
Sub cherche_plusieurs()
[A:C].Interior.ColorIndex = xlNone
nom = InputBox("Nom cherché?")
If nom = "" Then Exit Sub
Set c = [A:A].Find(nom, , , xlWhole)
If Not c Is Nothing Then
premier = c.Address
Do
c.Resize(, 3).Interior.ColorIndex
= 4
Set c = [A:A].FindNext(c)
Loop While Not c Is Nothing And c.Address
<> premier
End If
End Sub
Non concordance
Colorie les objets de la colonne A non trouvés dans D2:D5.
Sub coloriage()
Set typecat = Range("D2:D5")
Set inventaire = Range("A2:A" & [A65000].End(xlUp).Row)
inventaire.Interior.ColorIndex = xlNone
For Each c In inventaire
If typecat.Find(c, MatchCase:=True) Is Nothing
Then c.Interior.ColorIndex = 3
Next c
End Sub
Recherche de la dernière ligne ou dernière colonne de la feuille ou d'un champ
Sur cet exemple, nous recherchons la dernière ligne et la dernière colonne de la feuille.
Sub dernièreligneFeuille()
Cells.Find("*", , , , xlByRows, xlPrevious).Select
End Sub
Sub dernièreColonneFeuille()
Cells.Find("*", , , , xlByColumns, xlPrevious).Select
End Sub
Sub IntersectionDerLigneColonneFeuille()
Cells(Cells.Find("*", , , , xlByRows, xlPrevious).Row,
Cells.Find("*", , , , xlByColumns, xlPrevious).Column).Select
End Sub
Nombre de lignes et de colonnes de la feuille.
Sub nbLignesFeuille()
MsgBox Sheets(1).Cells.Find("*", , , , xlByRows,
xlPrevious).Row & " Lignes"
MsgBox Sheets(1).Cells.Find("*", , , , xlByColumns,
xlPrevious).Column & " Colonnes"
End Sub
Sur cet exemple, nous recherchons la dernière ligne et la dernière colonne d'un champ.
Sub dernièreligneChamp()
[B6:D10].Find("*", , , , xlByRows, xlPrevious).Select
End Sub
Sub dernièreColonneChamp()
[B6:D10].Find("*", , , , xlByColumns, xlPrevious).Select
End Sub
Sub IntersectionDerLigneColonneChamp()
Cells([B6:D10].Find("*", , , , xlByRows, xlPrevious).Row,
[B6:D10].Find("*", , , , xlByColumns, xlPrevious).Column).Select
End Sub
Sélectionne de la ligne1 à la dernière ligne des colonnes D :E
x = "D:E"
Intersect(Range(x), Range("1:1")).Resize(Range(x).Find("*",
searchorder:=xlByRows, SearchDirection:=xlPrevious).Row).Select
Recherche de la première ligne vide dans un champ
Recherche la première ligne vide dans le champ A2:A1000
1 Nom
2 Dupont
3 Durand
4
5 Espinasse
6 François
7 Gaston
8 Hélène
9
10 Miroux
Sub ChercheLigneVide()
Set LigneVide = [A2:A1000].Find("", [A1000], xlValues,
, xlByRows, xlNext)
If Not LigneVide Is Nothing Then MsgBox LigneVide.Row
End Sub
Recherche de date
Le format de la date cherchée est le même que le format des dates du champ de recherche
Sub RechercheDateFind()
d = InputBox("Date? jj/mm/aa")
If d <> "" Then
On Error Resume Next
[L:L].Find(What:=CDate(d), LookIn:=xlValues).Select
If Err <> 0 Then MsgBox "Inconnu"
End If
End Sub
On adapte le format de la date recherchée au format des dates du champ de recherche
Sub RechercheDateFind2()
d = InputBox("Date? jj/mm/aa")
If d <> "" Then
On Error Resume Next
[N:N].Find(What:=Format(CDate(d), "dddd
d mmmm yyyy"), LookIn:=xlValues).Select
If Err <> 0 Then MsgBox "Inconnu"
End If
End Sub
Avec la fonction Equiv(), le format des dates du champ de recherche n'a pas d'importance
Sub RechercheDateColonneEquiv()
d = InputBox("Date?")
If IsDate(d) Then
p = Application.Match(CDbl(CDate(d)), [L2:L10000],
0)
If IsError(p) Then
MsgBox "Inconnu"
Else
[L2].Offset(p - 1, 0).Select
End If
Else
MsgBox "n'est pas une date"
End If
End Sub
Remplace les abréviations sélectionnées par les libellés
Sub traduc()
For Each c In Selection
a = Split(c, " ")
For i = LBound(a) To UBound(a)
Set temp = [abrev].Find(what:=a(i),
LookAt:=xlWhole)
If Not temp Is Nothing Then a(i) =
temp.Offset(, 1).Value
Next i
c.Value = Join(a, " ")
Next
End Sub
ou
Sub traduc2()
abr = [abrev].Value '
lecture dans un tableau
lib = [abrev].Offset(, 1).Value ' lecture dans un tableau
For Each c In Selection
a = Split(c, " ")
For i = LBound(a) To UBound(a)
p = Application.Match(a(i),
abr, 0)
If Not IsError(p) Then a(i)
= lib(p, 1)
Next i
c.Value = Join(a, " ")
Next
End Sub
Recherche de nombres avec Find
ValCherchée = InputBox("Valeur recherchée")
If IsNumeric(ValCherchée) Then ValCherchée = CDbl(ValCherchée)
Cells.Find(What:=ValCherchée).Activate
Colorie les occurences du mot cherché dans un champ
Colorie les occurences du mot cherché dans un champ
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$2" Then
If [iv1] = "" Then
[A4:A1000].Copy [IV4]
[iv1] = "archivé"
Else
[IV4:IV1000].Copy [A4]
End If
mot = Target
For Each c In [A4:A1000]
p = 1
Do While p > 0
p = InStr(p, UCase(c),
UCase(mot))
If p > 0 Then
c.Characters(p,
Len(mot)).Font.ColorIndex = 3
p
= p + Len(mot)
End If
Loop
Next c
End If
End Sub
Nettoyage d'une feuille
Parfois, le UsedRange d'une feuille (Maj+Ctrl+fin)
comporte des lignes et des colonnes après la dernière cellule
pleine.
Pour supprimer les lignes et colonnes inutilisées de la feuille:
- Nettoie
Used Range -
Sub SupLigneColTrop()
Range(Cells(Cells.Find("*", , , , xlByColumns, xlPrevious).Column
+ 1), Cells(1, 254)).EntireColumn.Delete
Range(Cells(Cells.Find("*", , , , xlByRows, xlPrevious).Row
+ 1, 1), Cells(65536, 1)).EntireRow.Delete
End Sub
Sub VisuUsedRange()
ActiveSheet.UsedRange.Select
End Sub
Recherche 2 critères
Recherche matricielle 2 critères
On suppose que le nom cherché est en F2 et le prénom
en G2 . Nom et Prenom sont 2 champs
nommés.
RechercheMat2Critères
Sub Recherche()
p = Evaluate("match(1,(nom=F2)*(prenom=G2),0)")
If Not IsError(p) Then
Range("nom")(1).Offset(p - 1).Select
Else
MsgBox "inconnu"
End If
End Sub
Le nom et le prénom sont dans des variables n et P.
Sub Recherche2()
n = "Martin"
p = "Daniel"
pos = Evaluate("match(1,(nom=""" &
n & """)*(prenom=""" & p & """),0)")
If Not IsError(pos) Then
Range("nom")(1).Offset(pos - 1).Select
Else
MsgBox "inconnu"
End If
End Sub
Recherche 2 critères dans un tableau
Sub RechercheMultiCritères()
n = "titi"
p = "Jean"
a = [NOM].Resize(, 3) ' recherche dans tableau + rapide
For i = 1 To UBound(a, 1)
If a(i, 1) = n And a(i, 2) = p Then
MsgBox a(i, 3)
End If
Next i
End Sub
Recherche 2 critères avec find
Sub FindMultiCritères()
n = "titi"
p = "jean"
Set c = [NOM].Find(n, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
premier = c.Address
Set temp = c.Offset(, 1)
Do
Set temp = Union(temp, c.Offset(,
1))
Set c = [NOM].FindNext(c)
Loop While Not c Is Nothing And c.Address <>
premier
End If
'-- recherche prénom
Set c = temp.Find(p, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
MsgBox c.Offset(, 1)
Else
MsgBox "non trouvé"
End If
End Sub
Recherche Find avec caractères accentués
Création d'une BD à partir de fiches
On recherche la position du mot prénom
dans les cellules. Prénom est écrit avec
ou sans accent.
On remplace la recherche du mot Prénom par la
recherche de Pr?nom.
Sub CréeBD()
Set f = Sheets("BD")
ligneBD = 2
For Each c In f.[A:A].SpecialCells(xlCellTypeConstants, 23).Areas
p = InStr(c.Cells(1, 1), ":") + 1
f.Cells(ligneBD, 3) = Trim(Mid(c.Cells(1, 1),
p))
f.Cells(ligneBD, 4) = cherche("Pr?nom",
c)
f.Cells(ligneBD, 5) = cherche("Adresse",
c)
f.Cells(ligneBD, 6) = cherche("Tph",
c)
ligneBD = ligneBD + 1
Next c
End Sub
Function cherche(quoi, où)
Set résultat = où.Find(quoi, LookIn:=xlValues,
LookAt:=xlPart)
If Not résultat Is Nothing Then
p = InStr(résultat.Value, ":")
+ 1
If p > 0 Then cherche = Trim(Mid(résultat.Value,
p))
End If
End Function
Recherche de toutes les cellules qui contiennent un mot accentué
On recherche toutes les cellules qui contiennent étudiant avec ou sans accent.
On remplace é par le joker ?
valeurCherchéeJoker = "?tudiant"
Find Accent
(0,04 s pour 25.000 lignes)
Find Recherche Accent
Sub FindAccent()
valeurCherchée = "étudiant"
valeurCherchéeJoker = "?tudiant"
Set champRecherche = [A:A]
Set résultat = champRecherche.Find(valeurCherchéeJoker,
LookIn:=xlValues, LookAt:=xlPart)
If Not résultat Is Nothing Then
premier = résultat.Address
Do
If sansAccent(résultat.Value) = sansAccent(valeurCherchée)
Then résultat.Interior.ColorIndex = 4
Set résultat = champRecherche.FindNext(résultat)
Loop While Not résultat Is
Nothing And résultat.Address <> premier
End If
End Sub
Function sansAccent(chaine)
codeA = "ÉÈÊËÔéèêëàçùôûïî"
codeB = "EEEEOeeeeacuouii"
temp = chaine
For i = 1 To Len(temp)
p = InStr(codeA, Mid(temp, i, 1))
If p > 0 Then Mid(temp, i, 1) =
Mid(codeB, p, 1)
Next
sansAccent = temp
End Function
Avec une recherche séquentielle (0,75s pour 25.000 lignes)
Sub RechSeqAccent()
valeurCherchée = "étudiant"
For Each c In Range([A2], [A65000].End(xlUp))
If sansAccent(c) = sansAccent(valeurCherchée)
Then c.Interior.ColorIndex = 4
Next c
End Sub
Recherche d'un mot dans une BD
La recherche se fait dans toutes les colonnes de la BD. Le filtrage est obtenu en masquant les lignes. On peut placer le curseur sur une ligne en cliquant dans la ListBox.
Private Sub B_ok_Click()
Application.ScreenUpdating = False
Set f = ActiveSheet
Me.ListBox1.Clear
Set plage = f.[A5].CurrentRegion
plage.Interior.ColorIndex = 2
Set plage = plage.Offset(1).Resize(plage.Rows.Count - 1)
Set c = plage.Find(Me.TextBox1, , , xlPart)
If Not c Is Nothing Then
i = 0
premier = c.Address
Do
Me.ListBox1.AddItem
Me.ListBox1.List(i, 0) = c.Value
Me.ListBox1.List(i, 1) = c.Row
c.Interior.ColorIndex = 3
i = i + 1
Set c = plage.FindNext(c)
Loop While Not c Is Nothing And c.Address <>
premier
End If
End Sub
Recherche d'un mot dans tout le classeur
Donne la liste des feuilles d'un classeur contenant le mot cherché.
Recherche mot dans tout le classeur
Private Sub B_ok_Click()
If Me.TextBox1 = "" Then Exit Sub
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Temp").Delete
On Error GoTo 0
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "Temp"
[A1] = Me.TextBox1
ligne = 2
For i = 1 To Sheets.Count - 1
With Sheets(i).Cells
If IsDate(Me.TextBox1) Then
Set c = .Find(CDate(Me.TextBox1),
LookIn:=xlValues, LookAt:=xlPart)
Else
Set c = .Find(Me.TextBox1,
LookIn:=xlValues, LookAt:=xlPart)
End If
If Not c Is Nothing Then
premier = c.Address
Do
temp
= [A1]
Sheets("temp").Hyperlinks.Add
Anchor:=Sheets("temp").Cells(ligne, 1), _
Address:="",
SubAddress:="'" & Sheets(i).Name & "'" &
"!" & c.Address, TextToDisplay:=temp
Cells(ligne,
2) = Sheets(i).Name
Cells(ligne,
3) = c.Address
ligne
= ligne + 1
Set
c = .FindNext(c)
Loop While Not c
Is Nothing And c.Address <> premier
End If
End With
Next i
End Sub
Supprimer les lignes vides
Cellules vides dans la colonne A
On Error Resume Next
[A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Cellules vides sur toutes les colonnes
For i = [A65000].End(xlUp).Row To 1 Step -1
If Application.CountA(Rows(i)) = 0 Then Rows(i).Delete
Next i
Cellules vides de la colonne B à la colonne H
Sub suplignesvides()
Set f = Sheets("feuil1")
Application.ScreenUpdating = False
For i = f.[A65000].End(xlUp).Row To 2 Step -1
If Application.CountA(Range(f.Cells(i, "b"),
f.Cells(i, "h"))) = 0 Then f.Rows(i).Delete
Next i
End Sub
Sub supLignesVides2()
Application.ScreenUpdating = False
Columns("b:b").Insert Shift:=xlToRight
Range("B2:B" & [A65000].End(xlUp).Row).FormulaR1C1
= "=IF(COUNTA(RC[1]:RC[7])=0,""sup"",0)"
Range("B2:B65000").SpecialCells(xlCellTypeFormulas,
2).EntireRow.Delete
Columns("b:b").Delete Shift:=xlToLeft
End Sub
Suppression des lignes et colonnes vides
For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
If Application.CountA(Rows(i)) = 0 Then Rows(i).Delete
Next i
For i = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
If Application.CountA(Columns(i)) = 0 Then Columns(i).Delete
Next i
Sélection de lignes
On veut sélectionner les lignes des années 2008.
Sub Selection2008()
Range("E2:E" & [A65000].End(xlUp).Row).FormulaR1C1
= "=IF(YEAR(RC[-1])=2008,""ok"")"
[E:E].SpecialCells(xlCellTypeFormulas, 2).EntireRow.Select
[E:E].ClearContents
End Sub
Suppression de lignes
Suppression classique
On supprime les lignes qui contiennent xxxx dans la première colonne
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = [A65000].End(xlUp).Row To 1 Step -1
If Cells(i, 1) = "xxxx" Then Rows(i).Delete Shift:=xlUp
Next i
Application.Calculation = xlCalculationAutomatic
ou
[A:A].Replace "xxxx", ""
[A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Avec le filtre automatique
SupLignesFiltreAuto
SupLignes Filtre Auto
tableau structuré
Sub SupLignesFiltreAuto()
[A1].AutoFilter Field:=1, Criteria1:="xxxx"
Range("_FilterDataBase").Offset(1, 0).Resize(Range("_FilterDataBase").
_
Rows.Count - 1).SpecialCells(xlCellTypeVisible).Delete
Shift:=xlUp
[A1].AutoFilter
End Sub
Avec le filtre élaboré
Supprime les exclus - xx yy zz - ( 0,1 S pour 10.000 lignes).
Au lieu de supprimer les lignes, on recopie dans une autre feuille ce
qui ne doit pas être supprimé.
Sub sup_filtre()
Sheets("result").[A:C].Clear
Sheets("BD").Range("A1:C12000").AdvancedFilter
Action:=xlFilterCopy, _
CriteriaRange:=Sheets("BD").Range("F1:F2"),
CopyToRange:=Sheets("result").Range("A1")
Sheets("result").Select
End Sub
A l'aide d'une colonne intermédiaire:
Sub supLignes()
Application.ScreenUpdating = False
Columns("b:b").Insert Shift:=xlToRight
Range("B2:B" & [A65000].End(xlUp).Row).FormulaR1C1
= "=IF(RC[-1]=""xxxx"",""sup"",0)"
Range("B2:B65000").SpecialCells(xlCellTypeFormulas,
2).EntireRow.Delete
Columns("b:b").Delete Shift:=xlToLeft
End Sub
On regroupe les lignes à supprimer en fin de tableau.
La suppression des lignes ainsi regroupées en fin de tableau est
très rapide.
L'ordre initial des lignes n'est pas modifié.
-on repère les lignes à supprimer avec la
valeur Sup
-on tri les lignes . Les lignes contenant Sup se retrouvent
à la fin
-on supprime les lignes contenant Sup
(0,2sec pour 20.000 lignes)
SupLignesRapide
SupLignesRapideCouleur
Sub supLignesRapide()
Application.ScreenUpdating = False
Columns("b:b").Insert Shift:=xlToRight
Range("B2:B" & [A65000].End(xlUp).Row).FormulaR1C1
= "=IF(RC[-1]=""xxxx"",""sup"",0)"
[B:B].Value = [B:B].Value
[A2].CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending,
Header:=xlGuess
On Error Resume Next
Range("B2:B65000").SpecialCells(xlCellTypeConstants,
2).EntireRow.Delete
Columns("b:b").Delete Shift:=xlToLeft
End Sub
Autre méthode (0,15 sec pour 20.000 lignes)
Sub supLignesRapide2()
Application.ScreenUpdating = False
a = Range("A2:A" & [A65000].End(xlUp).Row)
For i = LBound(a) To UBound(a)
If a(i, 1) <> "xxxx" Then a(i,
1) = 0 Else a(i, 1) = "sup"
Next i
Columns("b:b").Insert Shift:=xlToRight
[B2].Resize(UBound(a)) = a
[A2].CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending,
Header:=xlGuess
On Error Resume Next
Range("B2:B65000").SpecialCells(xlCellTypeConstants,
2).EntireRow.Delete
Columns("b:b").Delete Shift:=xlToLeft
End Sub
Suppression de lignes rapide d'un tableau structuré
Sup Lignes d'un tableau structuré
Sub supLignesRapide()
Application.ScreenUpdating = False
codes = Array(1, 2, 6) ' codes à conserver
a = [Tableau1]
ReDim b(1 To UBound(a), 1 To 1)
For i = LBound(a) To UBound(a)
If IsError(Application.Match(a(i, 2), codes, 0))
Then b(i, 1) = "sup" Else b(i, 1) = 0
Next i
Range("Tableau1[#all]").Columns(2).Insert Shift:=xlToRight
[Tableau1[colonne1]].Resize(UBound(b)) = b
[Tableau1].Sort Key1:=[Tableau1[colonne1]], Order1:=xlAscending,
Header:=xlYes
On Error Resume Next
[Tableau1[colonne1]].SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
[Tableau1[colonne1]].Delete Shift:=xlToLeft
End Sub
Suppression classique de lignes n'appartenant pas à une liste
Sub supLignesListeClassique()
Application.ScreenUpdating = False
Set f1 = Sheets("BD")
Set f2 = Sheets("Liste")
colCode = 5
colListe = 1
n = f2.Cells(65000, colListe).End(xlUp).Row
Liste = f2.Cells(2, colListe).Resize(n - 1)
For i = f1.Cells(Rows.Count, colCode).End(xlUp).Row To 2 Step
-1
c = Application.Match(f1.Cells(i, colCode), Liste,
0)
If IsError(c) Then f1.Rows(i).Delete
Next i
Application.ScreenUpdating = True
End Sub
Sub supLignesListeRapide()
Application.ScreenUpdating = False
Set f1 = Sheets("BD")
Set f2 = Sheets("Liste")
colcode = 5
colListe = 1
n = f2.Cells(65000, colListe).End(xlUp).Row
liste = f2.Cells(2, colListe).Resize(n - 1)
Set d = CreateObject("scripting.dictionary")
For Each c In liste: d(c) = "": Next c
n = f1.Cells(65000, colcode).End(xlUp).Row
a = f1.Cells(2, colcode).Resize(n - 1)
For i = LBound(a) To UBound(a)
If d.exists(a(i, 1)) Then a(i, 1) = 0 Else a(i,
1) = "sup"
Next i
Columns("b:b").Insert Shift:=xlToRight
[B2].Resize(UBound(a)) = a
[A2].CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending,
Header:=xlYes
On Error Resume Next
Range("B2:B65000").SpecialCells(xlCellTypeConstants,
2).EntireRow.Delete
Columns("b:b").Delete Shift:=xlToLeft
End Sub
Supprimer des lignes commençant par
Sub SupLignes3()
Application.ScreenUpdating = False
For i = [A65000].End(xlUp).Row To 1 Step -1
If Left(Cells(i, 1), 4) <> "SCVT"
Then Rows(i).Delete
Next i
End Sub
Suppression de lignes sur 3 colonnes
For i = [A65000].End(xlUp).Row To 1 Step -1
If Cells(i, 1) = "" Then Cells(i, 1).Resize(1, 3).Delete
Shift:=xlUp
Next i
Suppression de cellules vides
[A:D].SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
Supprime une ligne sur 2 (rapide)
Sub supLignes1sur2()
Application.ScreenUpdating = False
Columns("b:b").Insert Shift:=xlToRight
Range("B2:B" & [A65000].End(xlUp).Row).FormulaR1C1
= "=if(MOD(ROW(),2)=1,""sup"",0)"
Range("B2:B65000").SpecialCells(xlCellTypeFormulas,
2).EntireRow.Delete
Columns("b:b").Delete Shift:=xlToLeft
End Sub
Sub supLignes1sur2Rapide()
Application.ScreenUpdating = False
Columns("b:b").Insert Shift:=xlToRight
Range("B2:B" & [A65000].End(xlUp).Row).FormulaR1C1
= "=if(MOD(ROW(),2)=1,""sup"",0)"
[B:B].Value = [B:B].Value
[A2].CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending,
Header:=xlGuess
Range("B2:B65000").SpecialCells(xlCellTypeConstants,
2).EntireRow.Delete
Columns("b:b").Delete Shift:=xlToLeft
End Sub
Masquage de lignes
On masque les lignes si cellules vides dans colonne B
On Error Resume Next
Range("b:b").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden
= True
On masque les lignes si cellules vides dans toutes les colonnes
For i = 1 To [A65000].End(xlUp).Row
If Application.CountA(Rows(i)) = 0 Then Rows(i).Hidden
= True
Next i
Pour faire apparaître toutes les lignes de la feuille
Cells.EntireRow.Hidden = False
Masquer des groupes de lignes ou de colonnes
Range("5:10,15:20,25:30").EntireRow.Hidden =
True
Range("B:D,G:J").EntireColumn.Hidden = True
Insère une ligne vide entre les lignes
Range("A65000").End(xlUp).Select
For i = 1 To Selection.currentregion.Rows.Count - 1
ActiveCell.EntireRow.Insert
ActiveCell.Offset(-1, 0).Select
Next
Range("A2:A1000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Suppression de doublons
Sub supDoublonsTradi()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
[A1].Sort Key1:=Range("A2"), Order1:=xlAscending,
Header:=xlGuess
For i = [A65000].End(xlUp).Row To 2 Step -1
If Cells(i, 1) = Cells(i - 1, 1) Then Rows(i).Delete
Next i
Application.Calculation = xlCalculationAutomatic
End Sub
Suppression de doublons rapide
Lorsque le nombre de lignes devient important et si le
taux de suppression est élevé, la méthode ci dessous
est plus rapide( 1 s pour 10000 lignes contre 7 s).
Principe:
-Formule =SI(A2=A1;1;0) pour repérer les doublons avec la valeur
1
-Tri pour regrouper les lisgnes à supprimer
-Remplacer 1 par un vide
-Sélection et Suppression
Sub SupRapide1Critere()
Application.ScreenUpdating = False
[A1].Sort Key1:=Range("A2"), Order1:=xlAscending, _
Header:=xlGuess
Columns("b:b").Insert Shift:=xlToRight
[B1] = "ColB"
[B2].FormulaR1C1 = "=IF(RC[-1]=R[-1]C[-1],1,0)"
[B2].AutoFill Destination:=Range("B2:B" & [A65000].End(xlUp).Row)
[B:B].Value = [B:B].Value
[A2].CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending,
Header:=xlGuess
[B:B].Replace What:="1", Replacement:="", LookAt:=xlPart
Range("B2:B65000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Columns("b:b").Delete Shift:=xlToLeft
End Sub
Sub SupRapide2CriteresColAColB()
Application.ScreenUpdating = False
[A1].Sort Key1:=Range("A2"), Order1:=xlAscending, _
Key2:=Range("B2"), Order2:=xlAscending, _
Header:=xlGuess
Columns("b:b").Insert Shift:=xlToRight
[B1] = "ColB"
[B2].FormulaR1C1 = "=IF(AND(RC[-1]=R[-1]C[-1],RC[+1]=R[-1]C[+1]),1,0)"
[B2].AutoFill Destination:=Range("B2:B" & [A65000].End(xlUp).Row)
[B:B].Value = [B:B].Value
[A2].CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending,
Header:=xlGuess
[B:B].Replace What:="1", Replacement:="", LookAt:=xlPart
Range("B2:B65000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Columns("b:b").Delete Shift:=xlToLeft
End Sub
Suppression de doublons sans modifier l'ordre
Sur colonne A
Sub supdoublons()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set champ = Range("A1:A" & [A65000].End(xlUp).Row)
For i = [A65000].End(xlUp).Row To 1 Step -1
If Application.CountIf(champ, Cells(i, 1)) >
1 Then
Cells(i, 1).Delete Shift:=xlUp
' ou Rows(i).Delete
End If
Next i
Application.Calculation = xlAutomatic
End Sub
Sur colonne A et C
Rapide si taux de suppression faible. 2 s pour 10.0000 lignes et taux suppression 5%
Sub OrdreRespectéDictionary()
Set MonDico = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
i = 2
Do While Cells(i, "A") <> ""
If Not MonDico.Exists(Cells(i, "A")
& Cells(i, "C")) Then
MonDico.Add Cells(i, "A")
& Cells(i, "C"), Cells(i, "A") & Cells(i,
"C")
i = i + 1
Else
Rows(i).EntireRow.Delete
End If
Loop
End Sub
Complèter un champ
[A1:A20].SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
[A1:A20].Value = [A1:A20].Value
Autre cas
[A1].CurrentRegion.Resize(, 1).SpecialCells(xlCellTypeBlanks).FormulaR1C1
= "=R[-1]C"
[A1].CurrentRegion.Resize(, 1).Value = [A1].CurrentRegion.Resize(, 1).Value
Insère une ligne à la position du curseur et copie les formules
Sub InsèreCopieLigne()
ActiveCell.EntireRow.Insert
Rows(ActiveCell.Row + 1).Copy Rows(ActiveCell.Row)
On Error Resume Next
Rows(ActiveCell.Row).SpecialCells(xlCellTypeConstants, 23).ClearContents
End Sub
Recopie la dernière ligne et ne laisse que les formules
Sub RecopieDerniereLigne()
[A65000].End(xlUp).Offset(1, 0).Select
ActiveCell.Offset(-1, 0).EntireRow.Copy ActiveCell
On Error Resume Next
Rows(ActiveCell.Row).SpecialCells(xlCellTypeConstants, 23).ClearContents
End Sub
Pour affecter une macro au clic droit sur cette feuille :
Private Sub Worksheet_Activate()
Set temp = CommandBars("cell").Controls.Add
temp.Caption = "Recopie dernière ligne"
temp.OnAction = "recopie"
temp.FaceId = 120
temp.BeginGroup = True
End Sub
Private Sub Worksheet_Deactivate()
Application.CommandBars("Cell").Reset
End Sub
Remplacer une information
Replace()
Champ.Replace What:=valeur, Replacement:=valeur,
LookAt:=xlPart/XlWhole,
SearchOrder:=xlByRows/XlByColumns,
MatchCase:=False, SearchFormat:=True/False,
ReplaceFormat:=True/False
Remplace une chaîne de caractères par une autre chaîne.
Range(“A1:A10”).Replace " ", ""
Caractères spéciaux:
* : remplace un nombre indéderminé
de caractères
? : remplace 1 caractère
S'il y a un caractère spécial dans la chaîne, utiliser ~ devant le caractère spécial:
Sur cet exemple, on remplace le caractère * par une chaîne vide
aaa*aaa
bbbbb*bb
cc*ddd
Range(“A1:A10”).Replace "~* ", ""
Supprime les lignes se terminant par DE
mmm
mmmDE
mmm
mmm
mmmDE
mmm
[A:A].Replace What:="*DE", Replacement:="",
LookAt:=xlWhole
On Error Resume Next
[A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Remplacer VRAI/FAUX
Pour remplacer les valeurs booléennes VRAI et FAUX dans une feuille
Cells.Replace What:=True, Replacement:="x"
Cells.Replace What:=False, Replacement:=""
Positionnement du curseur
ScrollRow=ligne
ScrollColumn=colonne
ScrollRow positionne la ligne active
en haut de l'écran.
ScrollColumn positionne la colonne active à gauche
de l'écran.
Sur cet exemple, la cellule active est positionnée en haut de l'écran
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
ActiveWindow.ScrollRow = ActiveCell.Row
End Sub
Sur cet exemple, la ligne active est positionnée au milieu de l'écran.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If ActiveCell.Row > 12 Then
ActiveWindow.ScrollRow = ActiveCell.Row - 12
End If
End Sub
Positionne le curseur sur Activité suivant/précédent
Sub positionneActivitéSuivant()
On Error Resume Next
Range(Cells(2, ActiveCell.Column + 1), Cells(2, 255)).Find(What:="Activité",
SearchDirection:=xlNext).Select
ActiveWindow.ScrollColumn = ActiveCell.Column
End Sub
Sub positionneActivitéPrécédent()
On Error Resume Next
Range(Cells(2, ActiveCell.Column - 1), Cells(2, "A")).Find(What:="Activité",
SearchDirection:=xlPrevious).Select
ActiveWindow.ScrollColumn = ActiveCell.Column
End Sub
Application.goto(référence,scroll)
Sélectionne la référence spécifiée.
Si Scroll=True, le coin supérieur gauche de la
référence apparaît dans le coin supérieur gauche
de la fenêtre.
Application.Goto Reference:=Sheets(1).Range("A20"), scroll:=True
Positionne le curseur sur la date du jour ou la
suivante
La même date peut apparaître plusieurs fois
Sub auto_open()
p = Application.Match(CDbl(Date), [A1:A100], 1)
Application.Goto [A1].Offset(p - 1 + IIf(Cells(p, 1) = Date,
0, 1)), scroll:=True
End Sub
Définir la zone utilisable par l'opérateur
ScrollArea=champ
Définit le champ utilisable par l'utilisateur.
Sheets(1).ScrollArea = "a1:f10"
Zone visible à l'écran
champVisible = ActiveWindow.VisibleRange.Address
premLigne = ActiveWindow.VisibleRange.Row
derLigne = ActiveWindow.VisibleRange.Rows.Count
premCol = ActiveWindow.VisibleRange.Column
derCol = ActiveWindow.VisibleRange.Columns.Count
Commentaire dans une cellule
Ci dessous, nous créons un commentaire dans une cellule.
With Sheets(1).[A1]
If .Comment Is Nothing Then
.AddComment ' Création commentaire
.Comment.Shape.OLEFormat.Object.Font.Name = "Tverdana"
.Comment.Shape.OLEFormat.Object.Font.Size = 7
.Comment.Shape.OLEFormat.Object.Font.FontStyle
= "Normal"
End If
.Comment.Text Text:="Ceci est un commentaire..."
.Comment.Shape.TextFrame.AutoSize = True
.Comment.Visible = False
End With
Nommer les champs par VBA
Sub NommerChamps()
Range("A1").Select
For Each c In Range(ActiveCell, Cells(ActiveCell.Row, 254).End(xlToLeft))
If Not IsEmpty(c.Offset(1, 0)) Then
ActiveWorkbook.Names.Add Name:=c,
RefersTo:="=" & Range(c.Offset(1, 0), c.End(xlDown)).Address
End If
Next
End Sub
Sub NommerChampsDynamique()
Range("A1").Select
For Each c In Range(ActiveCell, Cells(ActiveCell.Row, 254).End(xlToLeft))
If Not IsEmpty(c.Offset(1, 0)) Then
ActiveWorkbook.Names.Add
Name:=c, RefersTo:= _
"=OFFSET("
& c.Address & ",,,COUNTA(" & c.EntireColumn.Address
& ")-1)"
End If
Next
End Sub
Modification de la police dans une cellule
Cells(1, 1) = "Ceci est un essai de caractères
en gras dans une cellule...."
Cells(1, 1).Characters(Start:=4, Length:=10).Font.FontStyle = "Gras"
Fusionner des cellules
Champ.Merge
Champ.MergeCells=True/False
Champ.Unmerge
Champ.Merge fusionne les cellules du champ spécifié.
Sur cet exemple, nous fusionons 2 colonnes dans une seule en conservant les données des 2 colonnes
Sub essai()
Application.DisplayAlerts = False
Lignedépart = 2
colonneDépart = 2
n = 4
For lig = Lignedépart To Lignedépart + n
Cells(lig, colonneDépart) = Cells(lig,
2) & Cells(lig, colonneDépart + 1)
Cells(lig, colonneDépart).Resize(1,
2).Merge
Next lig
End Sub
Fusion de 2 colonnes sans Merge
0,3 secondes pour 20.000 lignes
Sub FusionColBColCSansMerge()
Application.ScreenUpdating = False
lignedépart = 2
colonnedépart = 2
n = 20000
a = Cells(lignedépart, colonnedépart).Resize(n,
2).Value
For i = LBound(a) To UBound(a)
a(i, 1) = a(i, 1) & " " & a(i,
2)
Next i
Cells(lignedépart, colonnedépart).Resize(n,
2) = a
Cells(lignedépart, colonnedépart + 1).Resize(n).ClearContents
End Sub
Sur cet exemple, les codes articles identiques sont fusionnés dans une seule cellule.
 |
 |
Avant |
Après |
Sub merge()
Application.DisplayAlerts = False
i = 2
Do While Cells(i, 1) <> ""
m = i
Do While Cells(i, 1) = Cells(m, 1)
i = i + 1
Loop
Cells(m, 1).Resize(i - m).VerticalAlignment = xlTop
Cells(m, 1).Resize(i - m).MergeCells = True
Loop
End Sub
Sub Unmerge()
Range([A2], [a65000].End(xlUp)).Unmerge
Range([b2], [b65000].End(xlUp)).Offset(0, -1).SpecialCells(xlCellTypeBlanks).FormulaR1C1
= "=R[-1]C"
Range([A2], [a65000].End(xlUp)).Value = Range([A2], [a65000].End(xlUp)).Value
End Sub
Pour obtenir le champ complet d'une cellule fusionnée
If [B5].MergeCells Then MsgBox [B5].MergeArea.Address
Champs multi zones
La fonction RechercheMZ(valCherchée, champRech As Range, ChampRetour) donne une valeur associée à une valeur cherchée
=RechercheMZ(K2;(A2:A7;D2:D5;G2:G7);(B2:B7;E2:E5;H2:H7))
Si les champs ont étés nommés:
=RechercheMZ(K2;Noms;Salaire)
Function RechercheMZ(valCherchée, champRech As Range,
ChampRetour)
Application.Volatile
For i = 1 To champRech.Areas.Count
For j = 1 To champRech.Areas(i).Count
If valCherchée = champRech.Areas(i)(j)
Then
RechercheMZ = ChampRetour.Areas(i)(j)
Exit Function
End If
Next j
Next i
RechercheMZ = "pas trouvé"
End Function
Exemples
RAZ les cellules de la couleur choisie
Sélectionner le champ puis exécuter la macro.
Sub razcoul()
On Error Resume Next
Set x = Application.InputBox("cliquer sur une cellule
avec la couleur à effacer", Type:=8)
If Err = 0 Then
For Each c In Selection
If c.Interior.ColorIndex = x.Interior.ColorIndex
Then c.Value = Empty
Next c
End If
End Sub
Décale les mois vers la gauche
Sub glissant()
'-- décalage des 11 derniers mois sur le premier
Range("C1:M7").Cut Destination:=Range("B1")
'--- recopie la dernière colonne à droite
Range("L1:L7").AutoFill Destination:=Range("L1:M7"),
Type:=xlFillDefault
Range("M2:M7").ClearContents
'---- Prend le format de la colonne D et le copie en E
Range("b1:b7").Copy
Range("L1").PasteSpecial Paste:=xlFormats
Range("m2").Select
Cells.EntireColumn.AutoFit
End Sub
On veut supprimer les lignes qui existent déjà dans l'onglet BD1
On n'utilise pas de colonne intermédiaire
Sub SupDoublons()
Range("a2").Select
Do While ActiveCell <> ""
If Not IsError(Application.Match(ActiveCell, Application.Index(Range("base"),
, 1), 0)) _
And Not IsError(Application.Match(ActiveCell.Offset(0,
1), Application.Index(Range("base"), , 2), 0)) Then
ActiveCell.EntireRow.Delete
Else
ActiveCell.Offset(1, 0).Select
End If
Loop
End Sub
MEFC:
=SOMMEPROD((INDEX(Base;;1)=$A2)*(INDEX(Base;;2)=$B2)*(INDEX(Base;;1)<>"")*1)>0
On utilise une colonne intermédiaire(colonne C)
Sub SupDoublons2()
Range("C2").Select
ActiveCell.FormulaR1C1 = "=SUMPRODUCT((INDEX(Base,,1)=RC1)*(INDEX(Base,,2)=RC2)*1)>0"
ActiveCell.Copy Range(ActiveCell, ActiveCell.Offset(0, -1).End(xlDown).Offset(0,
1))
For Each c In Range(ActiveCell, ActiveCell.End(xlDown))
If c.Value = True Then c.EntireRow.Delete
Next c
Range(ActiveCell, ActiveCell.End(xlDown)) = Empty
End Sub
On veut copier en K2 les lignes surlignées en couleur Orange(couleur 44)
Sub Archives1()
[K2:N65000].ClearContents
ligneRecap = 1
For i = 2 To [a65000].End(xlUp).Row
If Cells(i, 1).Interior.ColorIndex = 44 Then
ligneRecap = ligneRecap + 1
Cells(i, 1).Resize(1, 4).Copy
Cells(ligneRecap, 11)
End If
Next i
End Sub
Vers un autre onglet
Sub Archives2()
Sheets("Archives").Range("A2:F65000").ClearContents
ligneRecap = 1
For i = 2 To [a65000].End(xlUp).Row
If Cells(i, 1).Interior.ColorIndex = 44 Then
ligneRecap = ligneRecap + 1
Cells(i, 1).Resize(1, 4).Copy Sheets("Archives").Cells(ligneRecap,
1)
End If
Next i
End Sub
Copie de lignes manquantes d’un classeur dans un autre
On ajoute à mois2.xls les lignes de mois1.xls manquantes dans mois2.xls
MFC:=NB.SI(nom1;A2)>0
MFC:=ET(NB.SI(nom2;A2)=0;A2<>"")
Sub CopieManque()
Sheets("BD").Select
Range("A2").Select
ligne = Workbooks("mois2.xls").Sheets("BD").[A65000].End(xlUp).Row
+ 1
Do While ActiveCell <> ""
If IsError(Application.Match(ActiveCell, Workbooks("mois2.xls").Sheets("BD").Range("nom"),
0)) Then
Range(ActiveCell, ActiveCell.Offset(0,
1)).Copy Workbooks("mois2.xls").Sheets("BD").Cells(ligne,
1)
ligne = ligne + 1
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Différence entre 2 fichiers
On veut connaître les produits qui existent dans Mois1.xls et qui n'existent pas dans Mois2.xls
Sub DiffFich1Fich2()
ligneEcrit = 2
nblignes = Workbooks("mois1.xls").Sheets("BD").[A65000].End(xlUp).Row
+ 1
For i = 2 To nblignes
x = Workbooks("mois1.xls").Sheets("BD").Cells(i,
1)
If IsError(Application.Match(x, Workbooks("mois2.xls").Sheets("BD").Range("nom"),
0)) Then
Cells(ligneEcrit, 1) =
x
ligneEcrit = ligneEcrit
+ 1
End If
Next i
End Sub
Sub DiffFich2Fich1()
ligneEcrit = 2
nblignes = Workbooks("mois2.xls").Sheets("BD").[A65000].End(xlUp).Row
+ 1
For i = 2 To nblignes
x = Workbooks("mois2.xls").Sheets("BD").Cells(i,
1)
If IsError(Application.Match(x, Workbooks("mois1.xls").Sheets("BD").Range("nom"),
0)) Then
Cells(ligneEcrit, 2) =
x
ligneEcrit = ligneEcrit
+ 1
End If
Next i
End Sub
Comparaison de bases multi-critères avec Array()
Sur cet exemple, nous transférons les BD dans des tableaux tnom(),tprenom(),tage() pouraccélérer la comparaison. Comparaison
Sub compareBD()
ligne = 2
tnom = [NomBD2]
tprenom = [prenomBD2]
tage = [ageBD2]
For i = 1 To Range("NomBD1").Count
n = Range("NomBD1")(i)
p = Range("PreNomBD1")(i)
a = Range("AgeBD1")(i)
témoin = False
If n <> "" Then
For k = 1 To Range("nomBD2").Count
If tnom(k, 1) = n And
tprenom(k, 1) = p And tage(k, 1) = a Then témoin = True
Next k
If Not témoin Then
Sheets("diff").Cells(ligne,
1) = n
Sheets("diff").Cells(ligne,
2) = p
Sheets("diff").Cells(ligne,
3) = a
ligne = ligne +
1
End If
End If
Next i
End Sub
Récupération d'un champ d'un classeur fermé
Récupère un champ d'un classeur fermé
Sub LitClasseurFermé()
ChampOuCopier = "A1:A4"
Chemin = ThisWorkbook.Path
Fichier = "stock.xls"
onglet = "Janvier"
ChampAlire = "B2:B5"
LitChamp ChampOuCopier, Chemin, Fichier, onglet, ChampAlire
End Sub
Sub LitChamp(ChampOuCopier, Chemin, Fichier, onglet, ChampAlire)
Range(ChampOuCopier).FormulaArray = "='" & Chemin
& "\[" & Fichier & "]" & onglet &
"'!" & ChampAlire
Range(ChampOuCopier) = Range(ChampOuCopier).Value
End Sub
Récupération du format des cellules pointées par des formules
Une feuille contient des formules du type
=Feuil2!C3
On veut que le format des cellules qui contiennent ces
formules soit modifié lorsque le format des
cellules pointées est modifié.
RécupèreFormats
RécupèreFormatsCommentaires
Private Sub Worksheet_Activate()
For Each c In ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas,
23)
tmp = c.Formula
If Not inclus(tmp, "[]*/+-") Then
a = Split(Mid(tmp, 2), "!")
If UBound(a) = 0 Then
Range(a(0)).Copy
Else
Sheets(a(0)).Range(a(1)).Copy
End If
c.PasteSpecial Paste:=xlPasteFormats
End If
Next c
End Sub
Function inclus(chaine, sch)
témoin = False
For i = 1 To Len(sch)
If InStr(chaine, Mid(sch, i, 1)) >
0 Then témoin = True
Next i
inclus = témoin
End Function
Coloriage des antécédents
Coloriage
antécédents
Evaluation expression
Transforme BD en tableau
Transforme tableau en BD
Transforme
Tableau BD
Transforme Tableau BD2
Sub TransformeLigneColonne()
Set f1 = Sheets("BD")
a = Sheets("Source").[B1].CurrentRegion
ligBD = 2
For ligne = 2 To UBound(a, 1)
For col = 2 To UBound(a, 2)
If a(ligne, col) > 0 Then
f1.Cells(ligBD, 1) = a(ligne,
1)
f1.Cells(ligBD, 2) = a(1,
col)
f1.Cells(ligBD, 3) = a(ligne,
col)
ligBD = ligBD + 1
End If
Next col
Next ligne
End Sub
Autre exemple
Sub TransformeBD2()
a = Sheets("Feuil1").Range("A1:D" &
[A65000].End(xlUp).Row)
Dim b()
ReDim b(1 To UBound(a) * 2, 1 To UBound(a, 2))
Set f1 = Sheets("feuil1")
ligBD = 1
colBD = 1
For ligne = 2 To UBound(a, 1)
For col = 3 To UBound(a, 2)
b(ligBD, colBD) = a(ligne, 1)
b(ligBD, colBD + 1) = a(ligne, 2)
b(ligBD, colBD + 2) = a(1, col)
b(ligBD, colBD + 3) = a(ligne, col)
ligBD = ligBD + 1
Next col
Next ligne
f1.[H2].Resize(UBound(b), UBound(b, 2)) = b
End Sub
Autre exemple
Sub transformeTableauBD()
Set f = Sheets("bd")
a = f.[A1:D8]
ligne = 2: colonne = 6
For col = 2 To UBound(a, 2)
For lig = 2 To UBound(a)
f.Cells(ligne, colonne) = a(1, col)
f.Cells(ligne, colonne + 1) = a(lig,
1)
f.Cells(ligne, colonne + 2) = a(lig,
col)
ligne = ligne + 1
Next lig
Next col
End Sub
Autre exemple
Sub TransformeTableauBD()
ligne = 2
For Each c In Range("A2:A" & [A65000].End(xlUp).Row)
For J = 1 To 3
Cells(ligne, 8) = c
Cells(ligne, 9) = c.Offset(, 1)
Cells(ligne, 10) = Val(c.Offset(,
J + 1))
ligne = ligne + 1
Next
Next c
End Sub
Autre exemple
Sub Transforme()
ligne = 2
For Each c In Range("A2:A" & [A65000].End(xlUp).Row)
a = Split(c.Offset(, 1), "/")
For j = LBound(a) To UBound(a)
Sheets(2).Cells(ligne, 1) = c
Sheets(2).Cells(ligne, 2) = a(j)
ligne = ligne + 1
Next
Next c
End Sub
Transformation de BD en tableau
TransformeColonnesLignes
TransformeColonneLigneEnfants
Sub ColonneLigne()
Application.ScreenUpdating = False
LigneBD = 2
LigneResult = 2
Do While Cells(LigneBD, 1) <> ""
temp = Cells(LigneBD, 1)
Sheets("result").Cells(LigneResult,
1) = Cells(LigneBD, 1)
c = 2
Do While Cells(LigneBD, 1) = temp
Sheets("result").Cells(LigneResult,
c) = Cells(LigneBD, 2)
c = c + 1
LigneBD = LigneBD + 1
Loop
LigneResult = LigneResult + 1
Loop
End Sub
Avec formules
-Sélectionner A2
=SI(MIN(SI(Code<>"";SI(NB.SI(A$1:A1;Code)=0;LIGNE(INDIRECT("1:"&LIGNES(Code))))))<>0;
INDEX(Code;MIN(SI(Code<>"";SI(NB.SI(A$1:A1;Code)=0;LIGNE(INDIRECT("1:"&LIGNES(Code)))))));"")
-Valider avec Maj+Ctrl+entrée
en B2:
=SI(COLONNES($B:B)<=NB.SI(Code;$A2);INDEX(val;EQUIV($A2;Code;0)+COLONNES($B:B)-1;1);"")
Autre exemple
Sub ColonneLigne()
LigneDest = 2
For LigneSource = 2 To [A65000].End(xlUp).Row
For j = 1 To Cells(LigneSource, 1)
Cells(LigneDest, 5) = Cells(LigneSource,
2)
Cells(LigneDest, 6) = Cells(LigneSource,
3)
LigneDest = LigneDest + 1
Next
Next
End Sub
Autre exemple
Sub ColonneLigne()
Set f1 = Sheets("Données initiales")
Set f2 = Sheets("Format final")
LigneDest = 2
For LigneSource = 2 To f1.[A65000].End(xlUp).Row
For j = f1.Cells(LigneSource, 1) To f1.Cells(LigneSource,
2)
f2.Cells(LigneDest, 1) = j
f2.Cells(LigneDest, 2) = f1.Cells(LigneSource,
3)
f2.Cells(LigneDest, 3) = f1.Cells(LigneSource,
4)
LigneDest = LigneDest + 1
Next
Next
End Sub
Autre exemple
Sub TransformeColooneLigne()
Application.ScreenUpdating = False
Range("A1").CurrentRegion.Sort Key1:=Range("A2"),
Header:=xlYes
Range("a2").Select
ligne = 2
Do While ActiveCell <> ""
mmatricule = ActiveCell
Sheets("résult").Cells(ligne,
1) = ActiveCell
Sheets("résult").Cells(ligne,
2) = ActiveCell.Offset(0, 1)
c = 3
Do While ActiveCell = mmatricule
Sheets("résult").Cells(ligne,
c) = ActiveCell.Offset(0, 2)
Sheets("résult").Cells(ligne,
c + 1) = ActiveCell.Offset(0, 3)
c = c + 2
ActiveCell.Offset(1, 0).Select
Loop
ligne = ligne + 1
Loop
Range("a2").Select
End Sub
Transformation de colonnes en lignes avec 2 niveaux de rupture
Tableau à convertir:
Ce que l'on veut obtenir
Sub TransformeColonneLigne()
Range("A1").CurrentRegion.Sort Key1:=Range("A2"),
Key2:=Range("b2"), Key3:=Range("b3"), Header:=xlYes
Range("a2").Select
ligne = 2
Do While ActiveCell <> ""
mIdCli = ActiveCell
Sheets("résult").Cells(ligne,
1) = ActiveCell
c = 2
Do While ActiveCell = mIdCli
Sheets("résult").Cells(ligne,
c) = ActiveCell.Offset(0, 1)
Sheets("résult").Cells(ligne,
c + 1) = ActiveCell.Offset(0, 2)
c = c + 2
mRefContt = ActiveCell.Offset(0, 1)
Do While ActiveCell = mIdCli And ActiveCell.Offset(0,
1) = mRefContt
ActiveCell.Offset(1, 0).Select
Loop
Loop
ligne = ligne + 1
Loop
End Sub
Transformation colonne en ligne avec formule matricielle
Transformation de fiches en BD
TransformeFicheBD
TransformeFicheBD2
Sub transpose()
début = 2
fin = [A65000].End(xlUp).Row
pas = 5
Dim a()
ReDim a(1 To (fin) / pas, 1 To 4)
For i = début To fin Step pas
For k = 0 To 3: a((i + pas - début) / pas,
k + 1) = Cells(i + k, 1): Next k
Next i
[C2].Resize((fin) / pas, 4) = a
End Sub
Sub transpose2()
début = 2
fin = [A65000].End(xlUp).Row
pas = 5
ligne = 2
For i = début To fin Step pas
For k = 0 To 3
Cells(ligne, 3 + k) = Cells(i + k,
1)
Next k
ligne = ligne + 1
Next i
End Sub
Trim Rapide
Sub TrimRapide()
t = Timer()
Columns("B:B").Insert Shift:=xlToRight
[B1:B12000].FormulaArray = "=TRIM(A1:A12000)"
[A1:A12000] = [B1:B12000].Value
Columns("B:B").Delete
MsgBox Timer() - t
End Sub
Sélection 1 ligne sur 2 rapide
-La formule =SI(MOD(LIGNE();2)=1;"";1)
dans la colonne B écrit 1 dans une cellule sur 2
- [B2:B65000].SpecialCells(xlCellTypeFormulas, 1).Offset(0, -1).Select
sélectione les cellules contenant une valeur.
Application.ScreenUpdating = False
Columns("b:b").Insert Shift:=xlToRight
[B2].FormulaR1C1 = "=IF(MOD(ROW(),2)=1,"""",1)"
[B2].AutoFill Destination:=Range("B2:B" & [A65000].End(xlUp).Row)
[B2:B65000].SpecialCells(xlCellTypeFormulas, 1).Offset(0, -1).Select
Columns("b:b").Delete Shift:=xlToLeft
Editeur de couleurs
Permet de modifier une couleur dans un champ - Editeur couleur -
Sub couleur()
On Error Resume Next
Set CelluleCoulAnc = Application.InputBox(prompt:=
"Cliquez sur la cellule contenant
la couleur à modifier", Type:=8)
If CelluleCoulAnc Is Nothing Then Exit Sub
On Error GoTo 0
anc = CelluleCoulAnc.Interior.ColorIndex
Range("A1").Select
retour = Application.Dialogs(xlDialogPatterns).Show
If retour = False Then Exit Sub
nouv = [A1].Interior.ColorIndex
Set champ = Application.InputBox(prompt:="Champ à
modifier", Type:=8)
For Each c In champ
If c.Interior.ColorIndex = anc Then c.Interior.ColorIndex
= nouv
Next c
End Sub
Liste des feuilles d'un classeur contenant un mot cherché
Private Sub B_ok_Click()
If Me.TextBox1 = "" Then Exit Sub
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Temp").Delete
On Error GoTo 0
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "Temp"
'--
ligne = 2
For Each s In ActiveWorkbook.Sheets
With Sheets(s.Name).Cells
Set c = .Find(Me.TextBox1, LookIn:=xlValues,
LookAt:=xlWhole)
If Not c Is Nothing Then
Sheets("temp").Cells(ligne,
1) = s.Name
ligne = ligne +
1
End If
End With
Next s
End Sub
Lettre no de colonne
col = 28
y = Replace(Replace(Cells(1, col).Address, "$", ""),
"1", "")
MsgBox y
Conversion adresses relatives en absolu
Sub convertFeuille()
On Error Resume Next
Set champ = Sheets(1).Cells.SpecialCells(xlCellTypeFormulas)
Set C = champ.Find(What:="[", LookIn:=xlFormulas,
LookAt:=xlPart)
If Not C Is Nothing Then
premier = C.Address
Do
C.Formula = _
Application.ConvertFormula(C.Formula,
fromReferenceStyle:=xlA1, toAbsolute:=xlAbsolute)
Set C = champ.FindNext(C)
Loop While Not C Is Nothing And C.Address <>
premier
End If
End Sub
Repérer les doublons dans des champs multi-feuilles
Sub ColoriageDoublons()
For Each t In Array("champ1", "champ2",
"champ3")
For Each c In Range(t)
For Each z In Array("champ1",
"champ2", "champ3")
For Each d
In Range(z)
If
c.Value = d.Value And c.Address <> d.Address Then
c.Interior.ColorIndex
= 4
f
= feuil(t)
temp
= c.Address
On
Error Resume Next
Sheets(f).Range(temp).Comment.Delete
Sheets(f).Range(temp).AddComment
Sheets(f).Range(temp).Comment.Text
Text:=feuil(z) & Chr(10) & d.Address
Sheets(f).Range(temp).Comment.Shape.TextFrame.AutoSize
= True
End
If
Next
d
Next z
Next c
Next t
End Sub
Function feuil(nom)
For Each n In ActiveWorkbook.Names
If n.Name = nom Then
a = Split(n, "!")
feuil = Mid(a(0), 2)
End If
Next n
End Function
Modification couleur de la sélection
Modifie la couleur du champ sélectionné à l'intérieur du champ B2:E20 et restitue les anciennes couleurs.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set champ = Range("A1:D20")
'---- restitution couleurs
If Not Intersect(champ, Target) Is Nothing And Target.Count
< 100 Then
CoulCurseur = RGB(255, 255, 0)
For Each n In ActiveWorkbook.Names
If Left(n.Name, 7) = "MémoAdr"
Then
adr = Mid(n.Name, 8):
Coul = Val(Mid(n, 2)): If Coul = 16777215 Then Coul = xlNone
If Range(adr).Interior.Color
= CoulCurseur Then Range(adr).Interior.Color = Coul
End If
Next n
'------ sauvegarde couleurs
For Each n In ActiveWorkbook.Names
If Left(n.Name, 7) = "MémoAdr"
Then n.Delete
Next n
For Each c In Target
ActiveWorkbook.Names.Add Name:="MémoAdr"
& Replace(c.Address, "$", ""), RefersTo:=c.Interior.Color
Next c
Target.Interior.Color = CoulCurseur
End If
End Sub
Curseur ligne
Sans gestion des couleurs
En cliquant sur une cellule d'un champ, la ligne est surlignée.
Les anciennes couleurs ne sont pas rétablies
lorsque le curseur est déplacé.
CurseurLigneSansCouleur
CurseurLigneSansCouleurMZ
CurseurLigneSansCouleurMZ3
jb-curseur
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set champ = Range("Lazone") ' ou Set champ = Range("B2:G12")
If Not Intersect(champ, Target) Is Nothing And Target.Count
= 1 Then
champ.Interior.ColorIndex = xlNone
col1 = champ.Column
col2 = col1 + champ.Columns.Count - 1
Range(Cells(Target.Row, col1), Cells(Target.Row,
col2)).Interior.ColorIndex = 36
End If
End Sub
Avec gestion des couleurs
En cliquant sur une cellule d'un champ, la ligne est surlignée. Les anciennes couleurs sont rétablies lorsque le curseur est déplacé.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set champ = [B1:E20] '
ou Set champ = range("MaZone")
For Each n In ActiveWorkbook.Names
If n.Name = "mémoNcol"
Then trouvé = True
Next n
If trouvé Then
'---- restitution des couleurs
ncol = [mémoNCol]
For i = 1 To ncol
x = "mémoAdresse" &
i
a = Evaluate([x])
x = "mémoCouleur" &
i
b = Evaluate([x])
Range(a).Interior.ColorIndex = b
Next i
End If
'--- mémorisation des couleurs --------------------------
If Not Intersect(champ, Target) Is Nothing And Target.Count = 1 Then
col1 = champ.Column
col2 = champ.Column + champ.Columns.Count - 1
ncol = col2 - col1 + 1
ActiveWorkbook.Names.Add Name:="mémoNcol",
RefersToR1C1:= _
"=" & Chr(34) & ncol & Chr(34)
For i = 1 To ncol
ActiveWorkbook.Names.Add Name:="mémoAdresse"
& i, RefersToR1C1:= _
"=" & Chr(34)
& Cells(Target.Row, i + col1 - 1).Address & Chr(34)
ActiveWorkbook.Names.Add Name:="mémoCouleur"
& i, RefersToR1C1:= _
"=" & Cells(Target.Row,
i + col1 - 1).Interior.ColorIndex
Cells(Target.Row, i + col1 - 1).Interior.ColorIndex
= 6
Next i
End If
End Sub
Curseur ligne/colonne
Curseur ligne/colonne. Les anciennes couleurs sont restituées.
CurseurLigneColonneAvecMFC
CurseurLigneChampAvecMFC
CurseurLigneColonneSansMFC
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set champ = Range("A1:M20")
If Me.CheckBox1 Then
If Not Intersect(champ, Target) Is Nothing Then
champ.FormatConditions.Delete
If Target.Count = 1 Then
Union(Intersect(Target.EntireRow,
champ), Intersect(Target.EntireColumn, champ)).FormatConditions.Add Type:=xlExpression,
Formula1:="VRAI"
Union(Intersect(Target.EntireRow,
champ), Intersect(Target.EntireColumn, champ)).FormatConditions(1).Interior.ColorIndex
= 36
End If
End If
Else
champ.FormatConditions.Delete
End If
End Sub
Curseur rouge
Remplace le curseur de la cellule active par un curseur rouge. On peut aussi choisir une forme ovale.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
ActiveSheet.Shapes("Curseur").Visible = True
If Err <> 0 Then
ActiveSheet.Shapes.AddShape(msoShapeRectangle,
6, 6, 8, 6).Name = "curseur"
ActiveSheet.Shapes("Curseur").Fill.Transparency
= 1
ActiveSheet.Shapes("curseur").Line.Visible
= True
ActiveSheet.Shapes("curseur").Line.ForeColor.SchemeColor
= 10
ActiveSheet.Shapes("curseur").Line.Weight
= 3
End If
ActiveSheet.Shapes("curseur").Left = Target.Left
ActiveSheet.Shapes("curseur").Top = Target.Top
ActiveSheet.Shapes("curseur").Height = ActiveCell.Height
ActiveSheet.Shapes("curseur").Width = ActiveCell.Width
End Sub
Curseur multiple
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect([a2:a13], Target) Is Nothing Then
[A1:J13].Interior.ColorIndex = xlNone
ligne = Target.Row
If Cells(ligne, "k").End(xlToLeft).Column
= 1 Then Exit Sub
Set horiz = Range(Cells(ligne, "a"),
Cells(ligne, "k").End(xlToLeft))
horiz.Interior.ColorIndex = 6
For Each c In horiz
If c = "x" Then
Range(c, Cells(1, c.Column)).Interior.ColorIndex = 6
Next c
End If
Colorie la dernière cellule modifiée
Colorie dernière cellule modifiée
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count = 1 Then
On Error Resume Next
If [mémoAdresse] <> ""
Then Range([mémoAdresse]).Interior.Color = [mémoCouleur]
On Error GoTo 0
ActiveWorkbook.Names.Add Name:="mémoAdresse",
RefersToR1C1:="=" & Chr(34) & Target.Address & Chr(34)
ActiveWorkbook.Names.Add Name:="mémoCouleur",
RefersToR1C1:="=" & Target.Interior.Color
Target.Interior.Color = RGB(255, 0, 0)
End If
End Sub
Mise en forme d'une BD
Private Sub Worksheet_Activate()
Sheets("feuil2").Select
[1:10000].Delete
Sheets("feuil1").[A1].CurrentRegion.Copy [A1]
[A1].CurrentRegion.Sort Key1:=Range("C2"), Order1:=xlAscending,
Header:=xlGuess
i = 2
Do While Cells(i, 3) <> ""
temp = Cells(i, 3)
Rows(i).Insert
Cells(i, 1) = temp
Cells(i, 1).Resize(, 4).Interior.ColorIndex
= 6
Cells(i, 1).Resize(, 4).Merge
Cells(i, 1).HorizontalAlignment =
xlCenter
i = i + 1
Do While Cells(i, 3) = temp: i = i
+ 1: Loop
Loop
End Sub
Autre exemple
Private Sub Worksheet_Activate()
[1:10000].Delete
Sheets("BD").[A1].CurrentRegion.Copy [A1]
[A1].CurrentRegion.Sort Key1:=[A2], Order1:=xlAscending, Header:=xlGuess
i = 2
Do While Cells(i, 1) <> ""
temp = Left(Cells(i, 1), 1)
Rows(i).Insert
Cells(i, 1) = temp
Cells(i, 1).Font.Bold = True
Cells(i, 1).Resize(, 3).Interior.ColorIndex =
6
Cells(i, 1).Resize(, 3).Merge
i = i + 1
Do While Left(Cells(i, 1), 1) = temp: i = i +
1: Loop
Loop
End Sub
Rupture
Sub rupture()
Application.DisplayAlerts = False
On Error Resume Next
Sheets("BD2").Delete
On Error GoTo 0
Sheets("BD").Copy after:=Sheets(1)
ActiveSheet.Name = "BD2"
ligne = 2
Do While Cells(ligne, 1) <> ""
activité = Cells(ligne, 3)
Rows(ligne).Insert
Cells(ligne, 1) = activité
Cells(ligne, 1).Font.Bold = True
ligne = ligne + 1
Do While Cells(ligne, 3) = activité
ligne = ligne + 1
Loop
Loop
Columns(3).Delete
End Sub
Transformation d'un tableau
Sub Transforme()
Set f1 = Sheets("BD")
Set f2 = Sheets("Résult")
ligneBD = 2
finBD = f1.[B65000].End(xlUp).Row
LigneResult = 2
Do While ligneBD <= finBD
marque = f1.Cells(ligneBD, 1)
Do While (f1.Cells(ligneBD, 1) = marque
Or f1.Cells(ligneBD, 1) = "") And ligneBD <= finBD
ref = f1.Cells(ligneBD, 2)
f2.Cells(LigneResult, 1) = f1.Cells(ligneBD,
1)
numeros = f1.Cells(ligneBD,
3)
a = Split(numeros, "/")
For i = LBound(a) To UBound(a)
f2.Cells(LigneResult,
2) = ref
f2.Cells(LigneResult,
3) = Trim(a(i))
LigneResult = LigneResult
+ 1
Next i
ligneBD = ligneBD + 1
Loop
Loop
End Sub
Mise à jour d'une BD avec un tableau de modifications
Sub MajBD()
Set f1 = Sheets("BD")
Set f2 = Sheets("modif")
For Each c In f2.Range("a2:a" & f2.[a65000].End(xlUp).Row)
p = Application.Match(c, f1.Range("a2:a"
& f1.[a65000].End(xlUp).Row), 0)
If Not IsError(p) Then c.Resize(, 5).Copy f1.Cells(p
+ 1, 1)
Next c
End Sub
Création de combinaisons
Met en gras et rouge les nombres>50
13 12 78
14 12 52
15 51 13
781 12 15
Sub Sup50()
seuil = 50
For Each c In Range("A2:A" & [A65000].End(xlUp).Row)
a = Split(c, " ")
For i = LBound(a) To UBound(a)
If Val(a(i)) > seuil Then
p = InStr(c, a(i))
If p > 0 Then
c.Characters(Start:=p,
Length:=Len(a(i))).Font.Bold = True
c.Characters(Start:=p,
Length:=Len(a(i))).Font.ColorIndex = 3
End If
End If
Next i
Next c
End Sub