Gestion des cellules

Accueil


Definir un champ
Positionner le curseur
Cellule Active
Déplacer le curseur
Masquer la Maj de l'écran
Sélectionner la région courante
Redefinir la taille d'un champ
Sélectionner des cellules particulières

Selectionner la zone utilisée dans la feuille
Union et intersection de champs
Rechercher une information(Find)
Derniere ligne d'un champ
Recherche de date(Find)
Find Accent
Recherche dans tout le classeur
Remplacer une information(Replace)
Remplacer VRAI FAUX
Nommer les champs par VBA
Fusion de cellules
Champs Multi Zones


-RAZ des cellules de la couleur choisie
-Décaler les mois
-Supprimer lignes qui existent déjà
-
Copier les lignes coloriées
-Copier les lignes manquantes
-Colorie les occurences d'un mot cherché
-Recherche 2 critères
-Recherche d'un mot dans une BD
-Recherche d'un mot dans tout le classeur
-Différence entre 2 BD
-
Différence entre 2 BD multi-critères
-NettoyageFeuille
-Supprimer des lignes vides
-Suppression de lignes
-Suppression de lignes rapide
-Supprime une ligne sur 2
-Supprimer des doublons
-Compléter un champ
-Supprimer les lignes commençant par
-Insère ligne avec copie formules
-Masquage de lignes
-Récupération d'un champ d'un classeur fermé
-Récupération du format des cellules pointées
-Coloriage des antécédents
-Transforme BD en tableau
-Transforme Tableau en BD
-Transforme fiches en BD
-Transforme ligne en colonne
-Transforme colonne en ligne
-Transforme colonne ligne matricielle
-Colonne en ligne avec 2 niveaux rupture
-Trim rapide
-Sélection 1 Ligne sur 2
-Editeur couleur
-Liste des feuilles contenant un mot cherché
-Repérer les doublons multi-feuilles
-Modification de la couleur de la sélection
-Curseur ligne
-Curseur Ligne/Colonne
-Mise en forme d'une BD

Range
Cells
ActiveCell
ScreenUpdating
CurrentRegion
Selection.End
Resize
SpecialCells
UsedRange
Union
Intersect
ScrollArea
Find
SpecialCells
UsedRange
Replace
ScrollRow
ScrollColumn

ScrollArea
Merge-Unmerge
Application.Goto

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)
Selection.SpecialCells(xlCellTypeVisible)
SpecialCells(xlCellTypeLastCell)

Cellules vides
Cellules visibles
Dernière cellule de la feuille

-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

Tri 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)

Union Dynamique

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)

Find Synthèse

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.

NonConcordance

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.

Find Dernier.xls

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

Find Dates.xls

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

ChercheRemplaceFind

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

ChercheMotChamp

Colorie les occurences du mot cherché dans un champ

ChercheMot

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

Reherche2crit

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.

Find Accent

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.

Recherche mot dans une BD

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

SupLignesVidesColonne

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.

Selection Lignes 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

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é.

SupLignesFiltre

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:

SupLignes

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

Suppression rapide

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

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)

Sup1LigneSur2

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

- SupDoublonsRapide -

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

Recopie Formule

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

ScrollColumn

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

PositionneSuivant

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

Recherche Multi-Zones

=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.

RazCouleur

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

Glissant

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

TransformeBDTableau

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

ConvBD

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

Transforme Tableau BD

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

Conv Tableau Ligne Colonne

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

ColonneLignes

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

Transforme colonnes en lignes

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é

- Cherche mot 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"
  '--
  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

DoublonsChampsMultiFeuilles

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.

CurseurModifieCouleur

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é.

CurseurLigne
CurseurLigneMZ

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.

Curseur Rouge

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

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

BDMiseForme

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

Mef

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

Transforme 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

Maj BD

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

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

 

 

 

 


 


 

 


 

 


 

Exemples

Cellules Synthèse
Sup Lignes Vides
Masque Colonnes
Sup Lignes Mot
Suppression Doublons
Replace
ApplicationGotoScroll
Maj BD
Différence BD
Compare 2 BD
Fusion 2 Listes
Union 1 ligne Sur 2
Recopie Formule
Comparaison 2 BD
Recherche Mat 2 Critères
Curseur
Union Diff Listes
Recherche Multi-Zones
Trim Rapide
Nettoie Used Range
Coloriage Formules
InsèreLignesGroupe
Comparaison 2BD
ComparaisonBD2
ComparaisonBD4

Find

Find Synthèse
Find Dernier.xls
Find Dates.xls
Find Plusieurs
Find Multi-Feuilles
Find Recherche Accent
Find 2 Criteres
Find Vide Lignes

Merge

Merge UnMerge1
Merge Unmerge2
Merge Colonnes

Ecriture formules

Ecrit Formule Somme
Ecrit Formule
Ecrit Formule2
Ecrit Formule3
Ecrit Formule SousTotaux