Gestion Des Cellules - Formation Excel VBA JB

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 :

Find occurences

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

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

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

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

Sup Lignes Liste rapide

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)

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