Eviter les doublons lors d'un encodage dans un colonne de feuille excel:
=NB.SI($A$2:$A$21;A2)>1
Si vous souhaitez insérer la date du jour en cours dans une cellule, au format JJ/MM/AAAA, et que celle-ci reste fixe, sans remise à jour à chaque ouverture du fichier (par exemple pour indiquer la date de création du fichier):
Sub distri_couleur()
Dim i
For i = 1 To 12
Worksheets(1).Range("C" & i).Value = Worksheets(1).Range("B" & i).Interior.Color
Next i
End Sub'Remplacer le 10 par le nombre de lignes que vous souhaitez traiter.
Pour figer la ligne 1 (par exemple) dans une feuille excel :
Pour insérer une image gif animée dans un classeur Excel, le réflexe est de faire le menu insertion / image, mais cela ne fonctionne pas. C'est normal car l'animation est faite par plusieurs images et l'importation se limite à la première.
Private Sub Worksheet_Activate() WebBrowser1.Navigate "X:\chemin complet de l'image.GIF" End Sub
WebBrowser2.Navigate "X:\chemin complet de l'image.GIF"
Souvent la gestion d'un classeur, avec seulement les fonctions standards du tableur, pose des problèmes d'utilisation.
C'est une procédure qui demande un investissement personnel et qui n'est pas nécessairement facile à comprendre et à réaliser dès la première fois.
=SI(A1<>"";DECALER(d_noms;EQUIV(A1&"*";l_noms;0)-1;;SOMMEPROD((STXT(l_noms;1;NBCAR(A1))=TEXTE(A1;"0"))*1));l_noms)en remplaçant A1 par l'identification de la première cellule sélectionnée (c'est à dire la 1ère cellule ayant une validation par liste).
Voici quelques formules de bases qui sont faciles à réaliser et qui peuvent donner un peu de vie à une feuille Excel !
=SI(condition ; valeur "si vrai" ; valeur "sinon")Exemple :
=si(A1<=0 ; « à commander » ; « en stock »)Ce qui donnerait en language courant : Si le contenu de la cellule A1 est inférieur ou égal à zéro, alors on affiche "à commander", sinon (si le contenu de la cellule A1 est supérieur à zéro) on affiche "en stock".
Vous avez un tableau et vous l'avez nommé NomTableau (par exemple) avec :
Vous avez une date en C3 par exemple, et vous voulez connaitre :
Vous devez créer un tableau avec le nom des mois dans une ligne ou une colonne :
Vous souhaitez insérer un logo sous JPEG ou autre, sous votre grille Excel :
Vous avez créé votre tableau, et il y a plusieurs constantes plusieurs fois utilisées (TVA, Taux horaire, etc..).
Dans votre tableau, vous souhaitez insérer un texte ou une valeur choisi dans une liste (déroulante).
Les didacticiels Excel sont chiches en petits trucs utiles, qui font toute la différence entre une utilisation besogneuse et une certaine souplesse. Aussi, les butineurs du forum sont-ils invités à ajouter leurs heureuses expériences, en réponse et à la suite de ce sujet.
Private Sub CommandButton1_Click()
TimeOnOFF = Not TimeOnOFF
If TimeOnOFF Then
Smem = 0
Timer
End If
End Sub
Public TimeOnOFF As Boolean
Public Smem As Integer
Sub Timer()
Dim VV
If TimeOnOFF Then
'Mettre code ici pour être exécuté toute les secondes
Smem = Smem + 1
If Smem = 1 Then
Sheets("feuil1").[C1] = Time
ElseIf Smem = 2 Then
'Mettre code ici pour être exécuté toute les 2 secondes
Sheets("feuil1").[C1] = Replace(Time, ":", " ")
Smem = 0
Else
Smem = 0
End If
VV = TimeSerial(Hour(Time), Minute(Time), Second(Time) + 1)
Application.OnTime VV, "timer", False
End If
End Sub
Option Explicit
Public Collect As Collection
Public CollectC As Collection
Public Sub InitOption()
Dim Obj As OLEObject
Dim Cl As Classe1
Set Cl = Nothing
Set Collect = New Collection
Workbooks("Collections.xls").Activate
'boucle sur les objets de la Feuil1
For Each Obj In Sheets("Feuil1").OLEObjects
'verifie s'il s'agit d'un OptionButton
If TypeOf Obj.Object Is MSForms.OptionButton Then
Set Cl = New Classe1
Set Cl.OptionButtonGroup = Obj.Object
Collect.Add Cl
End If
Next Obj
End Sub
Public Sub InitCheck()
Dim Obj As OLEObject
Dim CO As Classe1
Set CO = Nothing
Set CollectC = New Collection
Workbooks("Collections.xls").Activate
'boucle sur les objets de la Feuil1
For Each Obj In Sheets("Feuil1").OLEObjects
'verifie s'il s'agit d'une Checkbox
If TypeOf Obj.Object Is MSForms.CheckBox Then
Set CO = New Classe1
Set CO.CheckBoxGroup = Obj.Object
CollectC.Add CO
End If
Next Obj
End Sub
Sub ActivationCollect()
InitOption
InitCheck
End Sub
'--------------------------------------
'Dans un module de classe nommé "Classe1"
'
Option Explicit
Public WithEvents OptionButtonGroup As MSForms.OptionButton
Public WithEvents CheckBoxGroup As MSForms.CheckBox
'Evenement Click sur les CheckBox de la feuille de calcul.
Private Sub CheckBoxGroup_Click()
'Renvoie le nom et la valeur de la CheckBox cliquée
MsgBox CheckBoxGroup.Name & ": " & CheckBoxGroup.Value
'Exemple qui renvoie dans la colonne A, la valeur de CheckBox
Cells(CheckBoxGroup.TopLeftCell.Row, 1) = CheckBoxGroup.Value
End Sub
'Evenement Click sur les CheckBox de la feuille de calcul.
Private Sub OptionButtonGroup_Click()
'Renvoie le nom et la valeur de l'OptionButton cliquée
MsgBox OptionButtonGroup.Name & ": " & OptionButtonGroup.GroupName
'Exemple qui renvoie dans la colonne A, la valeur de l'OptionButton
Cells(OptionButtonGroup.TopLeftCell.Row, 1) = OptionButtonGroup.Value
End Sub
Private Sub Workbook_Open()
InitOption
InitCheck
End Sub
Sub CréerBouton()
Dim Obj As Object
Dim Code As String
Sheets("Feuil1").Select
'crée le bouton
Set Obj = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
Link:=False, DisplayAsIcon:=False, Left:=200, Top:=100, Width:=100, Height:=35)
Obj.Name = "BoutonTest"
'texte du bouton
ActiveSheet.OLEObjects(1).Object.Caption = "Tester le bouton"
'Le texte de la macro
Code = "Sub BoutonTest_Click()" & vbCrLf
Code = Code & "Call Tester" & vbCrLf
Code = Code & "End Sub"
'Ajoute la macro en fin de module feuille
With ActiveWorkbook.VBProject.VBComponents(ActiveSheet.Name).CodeModule
.insertlines .CountOfLines + 1, Code
End With
End Sub
Sub Tester()
MsgBox "Vous avez cliquez sur le bouton test"
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cel As Range
For Each Cel In Target
'Adapter la/les plages.
If Not Intersect(Cel, Range("B1:B30,D1:D30")) Is Nothing Then
Select Case Cel.Value
Case 5 To 10: Cel.Interior.Color = vbRed
Case 11 To 20: Cel.Interior.Color = vbGreen
Case 21 To 30: Cel.Interior.Color = vbBlue
Case 31 To 50: Cel.Interior.Color = vbYellow
Case Else: Cel.Interior.ColorIndex = xlNone
End Select
End If
Next Cel
End Sub
Pour les accros et les inconditionnels des fonctions d'Excel, avant de crier au scandale, lisez les quelques lignes suivantes.
=RechercheVmulti($C$3;$B$3;$H$3)
=RechercheVmulti($C$3;$B$3;$A$3; 20)
Option Explicit
'RD =cellule où commencer la recherche
'RC = cellule critère
'RDT = cellule où chercher la donnée
'Ligne rechercher jusque ligne... (optional) si 0 cherche jusqu'au bout de la ligne
Public Function RechercheVmulti(RD As Range, RC As Range, RDT As Range, _
Optional Ligne As Long = 0)
Dim i As Integer, e As Integer, Txt As String
Dim LigE As Long, ColE As Long 'où écrire résultats
Dim Col As Integer
Dim Lig As Long, Occ As Long
Dim FeuilE As String, FeuilRD As String, FeuilRDT As String
On Error GoTo sortie
LigE = Application.Caller.Row
ColE = Application.Caller.Column
FeuilE = Application.Caller.Parent.Name
Application.Volatile
Lig = RD.Row ' Ligne où commencer la recherche
Col = RD.Column 'Colonne où commencer la recherche
FeuilRD = RD.Parent.Name
FeuilRDT = RDT.Parent.Name
If Ligne = 0 Then
Ligne = Range(Sheets(FeuilRD).Cells(65536, Col), Sheets(FeuilRD).Cells(65536, Col)).End(xlUp).Row
End If
'Recherche le numéro de l'occurrence à trouver
For Occ = LigE - 1 To 1 Step -1
Txt = Sheets(FeuilE).Cells(Occ, ColE).Formula
If Txt = Sheets(FeuilE).Cells(LigE, ColE).Formula Then
e = e + 1
End If
Next Occ
For i = Lig To Ligne
If Sheets(FeuilRD).Cells(i, Col) = RC Then
If e <> 0 Then
e = e - 1
Else
RechercheVmulti = Sheets(FeuilRDT).Cells(i, RDT.Column)
Exit Function
End If
End If
Next i
'Si plus trouvé de concordance
RechercheVmulti = ""
Exit Function
sortie:
'si erreur dans la formule, non détectée par Excel.
RechercheVmulti = "#FAUTE!"
End Function
Function NbSi_Plus(PlageRech As Variant, PlageCritere1 As Range)
Dim i As Integer, e As Integer, N As Integer, C1 As Integer
Dim M As Long, Mcont As Integer, Tot As Long
Dim TBF
Dim Cell As Range
Dim DebL As Long, FinL As Long
Dim DebC As Long, FinC As Long
Dim Col()
Dim Crit()
'Initialise les filtres
i = 0
For Each Cell In PlageRech
ReDim Preserve Crit(1, i)
If Cell <> "" Then
Mcont = Mcont + 1
Crit(1, i) = Asc(Cell) '60="<" 62=">"
If Len(Cell) > 1 Then
If Asc(Mid(Cell, 2, 1)) = 60 Or Asc(Mid(Cell, 2, 1)) = 62 Then
Crit(1, i) = 61
End If
End If
Select Case Crit(1, i)
Case 60, 62
Crit(0, i) = Mid(Cell, 2)
Case 61
Crit(0, i) = Mid(Cell, 3)
Case Else
Crit(0, i) = Cell
End Select
Else
Crit(1, i) = 0
End If
i = i + 1
Next Cell
'Rechercher si bloc ou toute la colonne
TBF = Split(PlageCritere1.Address, ":")
DebL = Range(TBF(0)).Row
DebC = Range(TBF(0)).Column
If UBound(TBF) > 0 Then
FinL = Range(TBF(1)).Row
End If
If DebL = FinL Or FinL = 0 Then
'faire le tri sur toute la hauteur de la colonne
FinL = Cells(65536, Range(TBF(0)).Column).End(xlUp).Row
End If
FinC = DebC + UBound(Crit, 2)
'Appliquer les filtres
For i = DebL To FinL
M = 0: C1 = 0
For e = DebC To FinC
If Crit(0, C1) <> "" Then
'For N = 0 To UBound(Crit, 2)
Select Case Crit(1, C1)
Case 60
If Cells(i, e) < Val(Crit(0, C1)) Then M = M + 1
Case 61
If Cells(i, e) <> Val(Crit(0, C1)) Then M = M + 1
Case 62
If Cells(i, e) > Val(Crit(0, C1)) Then M = M + 1
Case Is <> 0
If Cells(i, e) = CStr(Crit(0, C1)) Then M = M + 1
End Select
End If
C1 = C1 + 1
Next e
If M = Mcont Then Tot = Tot + 1
Next i
NbSi_Plus = Tot
End Function
Vous avez ouvert un fichier CSV avec Excel contenant une colonne de dates et ces dernières sont mal alignées. Elles sont par exemple tantôt alignées à droite, tantôt à gauche.
02/07/2005,machin 04/07/2005,bidule 17/07/2005,bleurp 01/07/2005,chouette
07/02/2005,machin 07/04/2005,bidule 07/17/2005,bleurp 07/01/2005,chouette
Le sommaire est le suivant:
Function M_Charge(plage As Range, Optional feuilles As String = "") As Variant
Dim cel As Range, i As Long, j As Integer, tablo() As Variant, tablof() As Variant
Dim f As Integer, feuille1 As String, feuille2 As String
Application.Volatile ' Permet un recalcul automatique
' Définition de la feuille par défaut si aucune feuille n'est mentionnée
If feuilles = "" Then feuilles = ActiveSheet.Name & ":" & ActiveSheet.Name
i = -1
If InStr(feuilles, ",") > 0 Then ' traitement des feuilles non contigues (séparées par des virgules)
While InStr(feuilles, ",") > 0
i = i + 1
ReDim Preserve tablof(i)
tablof(i) = Left(feuilles, InStr(feuilles, ",") - 1)
feuilles = Mid(feuilles, InStr(feuilles, ",") + 1, Len(feuilles) - InStr(feuilles, ","))
Wend
End If
i = i + 1
ReDim Preserve tablof(i)
tablof(i) = feuilles
i = -1
For f = LBound(tablof) To UBound(tablof) ' traite les différent blocs de feuilles
feuilles = tablof(f)
If InStr(feuilles, ":") = 0 Then feuilles = feuilles & ":" & feuilles ' je crée le bloc la feuille est seule
' Récupération de la feuille de début et la feuille de fin
feuille1 = Left(feuilles, InStr(feuilles, ":") - 1)
feuille2 = Right(feuilles, Len(feuilles) - InStr(feuilles, ":"))
' Passage en revue de toutes les feuilles entre Feuille1 et Feuille2
For j = Sheets(feuille1).Index To Sheets(feuille2).Index ' Each ws In Sheets(feuilles)
For Each cel In plage ' Pour chacune des cellules de la plage
i = i + 1
ReDim Preserve tablo(i) ' J'incrémente la table en cours de création
tablo(i) = Sheets(j).Cells(cel.Row, cel.Column).Value ' Récupélation de la valeur
Next
Next j
Next f
M_Charge = tablo ' Affectation du tableau à la fonction (la matrice est créée)
End Function
Cette fonction retourne la valeur du format actif d'une mise en forme conditionnelle.
Public Function CouleurMFC(RG As Range, Optional Mode As Byte = 0) As Variant
Dim e As Long, i As Byte, LoTest As Boolean
Dim LoMFC As FormatCondition
Application.Volatile
'boucle sur le nombre de condition(s)
'Si pas de MFC .FormatConditions.Count renvoi 0
For i = 1 To RG.FormatConditions.Count
Set LoMFC = RG.FormatConditions(i)
If LoMFC.Type = xlCellValue Then
'tester le type de la formule entrée
Select Case LoMFC.Operator
Case xlEqual
LoTest = RG = Evaluate(LoMFC.Formula1)
Case xlNotEqual
LoTest = RG <> Evaluate(LoMFC.Formula1)
Case xlGreater
LoTest = RG > Evaluate(LoMFC.Formula1)
Case xlGreaterEqual
LoTest = RG >= Evaluate(LoMFC.Formula1)
Case xlLess
LoTest = RG < Evaluate(LoMFC.Formula1)
Case xlLessEqual
LoTest = RG <= Evaluate(LoMFC.Formula1)
Case xlNotBetween
LoTest = (RG < Evaluate(LoMFC.Formula1) Or RG > Evaluate(LoMFC.Formula2))
Case xlBetween
LoTest = (RG >= Evaluate(LoMFC.Formula1)) And (RG <= Evaluate(LoMFC.Formula2))
End Select
If LoTest Then
'Peu ajouter d'autre format si nécessaire,
'comme la bordure, la police etc..
Select Case Mode
Case 0
CouleurMFC = LoMFC.Interior.ColorIndex
Case 1
CouleurMFC = LoMFC.Interior.Color
End Select
Exit Function
End If
End If
Next i
CouleurMFC = 0
End Function
=CouleurMFC(A2)
Sub CopieDBaccess()
Dim BDexp As Database
Dim Table As Recordset
Dim TbDef As TableDef
Dim Ch As String, Lig As Long, i As Integer
Ch = "Chemin & \ & NomDeLaBD.MDB"
Set BDexp = DBEngine.Workspaces(0).OpenDatabase(Ch)
Set Table = BDexp.OpenRecordset("NomDeLaTable", dbOpenDynaset)
'Debug.Print Table.Name
Set TbDef = BDexp.TableDefs("NomDeLaTable")
Lig = 3
dim Nom(TbDef.Fields.Count - 1) As String
'Place les titres des colonnes
With Sheets("Feuil1")
For i = 0 To TbDef.Fields.Count - 1 'Pour avoir toute la ligne
'Debug.Print TbDef.Fields(i).Name
Nom(i) = TbDef.Fields(i).Name
.Cells(Lig, i + 3) = Nom(i)
Next
'Caller sur le 1er enrégistrement
Table.MoveFirst
Lig = 4
While Not Table.EOF
For i = 0 To TbDef.Fields.Count - 1 'Pour avoir toute la ligne
.Cells(Lig, i + 3) = Table(Nom(i))
Next i
Lig = Lig + 1
Table.MoveNext 'Passer à l'enrégistrement suivant
Wend
End With
Table.Close
BDexp.Close
Set BDexp = Nothing
Set Table = Nothing
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static AncAdress As Long
'Si la fonction activer/Déactiver est implémentée ajouter la ligne ci-dessous
if ActivationLigne then exit sub
If Target.Count > 1 Then Exit Sub
If AncAdress <> 0 Then 'remettre en normal
Rows(AncAdress).Interior.ColorIndex = xlNone
Rows(AncAdress).Font.ColorIndex = 0
End If
Target.EntireRow.Font.ColorIndex = 6
Target.EntireRow.Interior.ColorIndex = 3
Target.EntireRow.Interior.Pattern = xlSolid
AncAdress = Target.Row
End Sub
Public ActivationLigne as boolean
Sub Activer()
ActivationLigne =not ActivationLigne
end sub
Private Sub CommandButton1_Click()
'En Non Modale, permet de laisser l'userforme afficher et
'de naviguer dans le nouveau classeur.
csvxls.Show 0
End Sub
Private Sub CommandButton1_Click()
SuppFichier = Supprimer_CVS.Value
SauveXLS = Sauver_XLS.Value
If Texte_Num.Value Then
TxtNum = 1
ElseIf OptNumeric Then
TxtNum = 2
Else
TxtNum = 3
End If
If Un_Seul_Fichier.Value = True Then
'Un seul fichier du répertoir
If SelectionFichier() Then
ConvertiCvsXls
End If
Else
'Tout un répertoir
ConvertiRep
End If
End Sub
Private Sub Sauver_XLS_Click()
Supprimer_CVS.Enabled = Sauver_XLS
If Not Sauver_XLS Then
Supprimer_CVS = False
End If
End Sub
Option Explicit Public Chemin As String Public Fichier As String Const Ext = "csv" 'Détermine si les fichiers du répertoire seront supprimer Public SuppFichier As Boolean 'Détermine si sauve en xls Public SauveXLS As Boolean 'Détermine si tous les fichiers du répertoire seront convertit Public Tous As Boolean 'Détermine sortie texte/Numérique Public TxtNum As Integer
Sub ConvertiRep()
Dim fs, F, f1, s, sf
Dim i As Long, Fin As Long
'-----------------------------------------------------------
'Sélectionner le répertoir
SelectionRep
'-----------------------------------------------------------
Set fs = CreateObject("Scripting.FileSystemObject")
Set F = fs.GetFolder(Chemin)
Set sf = F.Files
For Each f1 In sf
If LCase(Right(f1.Name, 3)) = Ext Then
Fichier = f1.Name
ConvertiCvsXls
End If
Next
End Sub
Sub ConvertiCvsXls()
Dim TB
Dim Lig As Long, i As Integer, AncNom As String
AncNom = Fichier
If Right(Chemin, 1) <> "" Then Chemin = Chemin & ""
Workbooks.Open Filename:=Chemin & Fichier
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With ActiveSheet
Select Case TxtNum
Case 1
.Cells.NumberFormat = "@"
Case 2
.Cells.NumberFormat = "0.000"
Case 3
.Cells.NumberFormat = "General"
End Select
For Lig = 1 To Range("A65536").End(xlUp).Row
'Changer la , (virgule) par le séparateur de votre fichier
TB = Split(.Cells(Lig, 1), ",")
For i = 0 To UBound(TB)
.Cells(Lig, i + 1) = TB(i)
Next i
Next Lig
End With
If SauveXLS Then
Fichier = Left(Fichier, Len(Fichier) - 3) & "xls"
If Dir(Chemin & Fichier) = "" Then
'le fichier xls n'existe pas encore
ActiveWorkbook.SaveAs Chemin & Fichier, FileFormat:=xlExcel9795 'Jusqu'au 2000
Workbooks(Fichier).Close SaveChanges:=False
Else
'le fichier xls existe, voir si ont l'écrase sans tomber en erreur.
If MsgBox("Le fichier " & Fichier & " existe déjà" & Chr(13) _
& "Faut-il l'écraser ?", vbQuestion + vbYesNo, "Ecraser fichier") = 6 Then
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Chemin & Fichier, FileFormat:=xlExcel9795 'Jusqu'au 2000
Workbooks(Fichier).Close SaveChanges:=False
Application.DisplayAlerts = True
ElseIf Tous Then
'Eviter la surcharge de classeur si tous les fichiers
Workbooks(AncNom).Close SaveChanges:=False
Else
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
End If
End If
End If
If SuppFichier Then
'supprime le fichier cvs
Kill Chemin & AncNom
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub SelectionRep()
Const ssfTous = &H1
Dim objShell As Object, objFolder As Object, oFolderItem As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", ssfTous)
Set oFolderItem = objFolder.Items.Item
Chemin = oFolderItem.Path
Set objShell = Nothing
Set objFolder = Nothing
Set oFolderItem = Nothing
End Sub
Function SelectionFichier() As Boolean
Dim nomfich As String, i As Integer
nomfich = Application.GetOpenFilename(FileFilter:="(*.csv),*.csv" _
, Title:="Sélectionnez le fichier à convertir")
If nomfich = "Faux" Then 'pas de sélection faite
Exit Function
End If
For i = Len(nomfich) To 2 Step -1
If Mid(nomfich, i, 1) = "" Then Exit For
Next i
Chemin = Left(nomfich, i)
Fichier = Mid(nomfich, i + 1)
SelectionFichier = True
End Function
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim i As Integer, j As Long, Mfc As FormatCondition, c As Range, Ws1 As Worksheet
On Error GoTo fin ' en cas de mauvaise manipulation, ça plante sur l'ordre suivant
Application.EnableEvents = False
Set Ws1 = Sheets("MFC")
For i = 1 To Target.FormatConditions.Count
Set Mfc = Target.FormatConditions(i)
If UCase(Left(Mfc.Formula1, 7)) = "=MA_MFC" Then
Ws1.Range("A1").Value = Target.Value
Set c = Nothing
For j = 2 To Ws1.Range("A65536").End(xlUp).Row
If Ws1.Range("A" & j) = True Then
Set c = Ws1.Range("A" & j)
Exit For
End If
Next j
If c Is Nothing Then Set c = Ws1.Range("A1")
c.Copy
Target.PasteSpecial (xlPasteFormats)
Application.CutCopyMode = False
End If
Next i
Application.EnableEvents = True
fin:
On Error GoTo 0
End Sub
'A mettre en tête du module Option Explicit Option Compare Text
Sub SupprimerMot()
Dim Cel As Range, Plage As Range
Dim Mot As String
Set Plage = Range("B2:B20") ' à adapter à la plage à parcourir.
Mot = "LeMot" 'adapter au mot à rechercher et à supprimer
'Pas nécessaire si le plage est petite
Application.ScreenUpdating = False
For Each Cel In Plage
If Cel Like "*" & Mot & "*" Then
Cel = Replace(Cel, Mot, "")
'Pour enlever le double espace qui en résulte..
Cel = Replace(Cel, " ", " ")
End If
Next Cel
Application.ScreenUpdating = True
End Sub
Sub SupprimerligneAvecMerge()
Dim Lig As Long
Dim Col As Integer
Dim Mot As String
Dim Mg, TB
'pour l'exemple, la colonne à tester =5
Col = 5
Mot = "LeMot" 'remplacer LeMot par celui que vous désirez chercher
For Lig = Cells(65536, Col).End(xlUp).Row To 1 Step -1
Set Mg = Cells(Lig, Col).MergeArea
TB = Split(Mg.Address, ":")
If Cells(Lig, TB(0)).Value = Mot Then
Rows(Lig).Delete
End If
Next Lig
End Sub
'Retourne toutes les adresses trouvées dans la recherche
'WkbN = nom du classeur, avec cette donnée la fonction peut être mise dans un xla
'WksN = nom de la feuille
'Plage = les coordonnées de la plage à parcourir.
'Retour dans le tableau donner en argument.
Function RechFind(ByVal Cle As String, ByVal WkbN As String, ByVal WksN As String, ByVal Plage As String, ByRef TBadress() As Variant) As Long
Dim Cherche, Ix As Long, PrAddress
With Workbooks(WkbN).Sheets(WksN).Range(Plage)
Set Cherche = .Find(Cle)
If Not Cherche Is Nothing Then
PrAddress = Cherche.Address
Do
ReDim Preserve TBadress(Ix)
TBadress(Ix) = Cherche.Address
Set Cherche = .FindNext(Cherche)
Ix = Ix + 1
Loop While Not Cherche Is Nothing And Cherche.Address <> PrAddress
End If
End With
'nombre d'occurence(s) trouvée(s), Retour 0 si aucune occurence
RechFind = Ix
Set Cherche = Nothing 'Libére la mémoire occupée par l'objet.
End Function
Sub RechMulti()
Dim R As Long, TB()
Dim i As Integer
R = RechFind("12*", ThisWorkbook.Name, "Feuil1", "B1:B500", TB())
If R > 0 Then
For i = 0 To R - 1 ' ou ubound(TB)
'exemple
Sheets("Feuil1").Cells(i + 4, 5) = Range(TB(i)).Row
Next i
End If
End Sub
Private Sub CommandButton1_Click()
Dim R As Long, TB()
Dim i As Integer
Range("E4:E20").ClearContents
R = RechFind(Range("E2"), ThisWorkbook.Name, ActiveSheet.Name, Range("B1:B500").Address, TB())
If R > 0 Then
For i = 0 To R - 1 ' ou ubound(TB)
'exemple
Sheets("Feuil1").Cells(i + 4, 5) = Range(TB(i)).Row
Next i
End If
End Sub
Option Explicit
Dim TempsS As Long
Dim TempsT As Long
Dim NumImg As Byte
Dim LG3 As Integer
Dim Deb As Integer
Private Sub UserForm_Activate()
Animation
End Sub
Private Sub UserForm_Initialize()
'------------------------------------------------------------------
'Les données par défaut
If TxtLab = "" Then
TxtLab = "Traitement en cour, veuillez patienter svp..."
End If
If VitesseS = 0 Then
VitesseS = 3500
End If
If VitesseT = 0 Then
VitesseT = 1000
End If
'------------------------------------------------------------------
OteTitleBarre Me.Caption, False
Me.Height = 43
NumImg = 1
ImgSablier.Picture = ListSablier.ListImages(NumImg).Picture
LabSablier.Caption = TxtLab
LG3 = LabSablier.Width
Animer = True
End Sub
Sub Animation()
While Animer
If VitesseS <> -1 Then
TempsS = TempsS + 1
If TempsS = VitesseS Then
TempsS = 0
NumImg = NumImg + 1: If NumImg > NbImage Then NumImg = 1
ImgSablier.Picture = ListSablier.ListImages(NumImg).Picture
End If
End If
If VitesseT <> -1 Then
TempsT = TempsT + 1
If TempsT = VitesseT Then
TempsT = 0
If Abs(Deb) > LG3 Then Deb = Frame1.Width
LabSablier.Left = Deb
Deb = Deb - 1
End If
End If
DoEvents
Wend
Unload Me
End Sub
Option Explicit
'Mettre à false pour fermer l'UF
Public Animer As Boolean
'Le texte qui défile dans l'UF,
Public TxtLab As String
'Pour adapter la vitesse de défilement du sablier
Public VitesseS As Integer
'Pour adapter la vitesse de défilement du texte
Public VitesseT As Integer
Public Const NbImage = 12
'----------------------------------------------------------------
'Pour enlever la barre de titre du UF
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Const GWL_STYLE = (-16)
Const WS_CAPTION = &HC00000
Const SWP_FRAMECHANGED = &H20
Public Declare Function FindWindowA Lib "user32" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function GetWindowRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) As Long
Public Declare Function GetWindowLong Lib "user32" Alias _
"GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias _
"SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Public Declare Function SetWindowPos Lib "user32" _
(ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, _
ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, _
ByVal wFlags As Long) As Long
Public Type POINTAPI
X As Long
Y As Long
End Type
Public m_CursorPos As POINTAPI
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Public Afficher As Boolean
Sub OteTitleBarre(stCaption As String, pbVisible As Boolean)
Dim vrWin As RECT
Dim style As Long
Dim lHwnd As Long
'- Recherche du handle de la fenêtre par son Caption
lHwnd = FindWindowA(vbNullString, stCaption)
If lHwnd = 0 Then
MsgBox "Handle de " & stCaption & " Introuvable", vbCritical
Exit Sub
End If
GetWindowRect lHwnd, vrWin
style = GetWindowLong(lHwnd, GWL_STYLE)
If pbVisible Then
SetWindowLong lHwnd, GWL_STYLE, style Or WS_CAPTION
Else
SetWindowLong lHwnd, GWL_STYLE, style And Not WS_CAPTION
End If
SetWindowPos lHwnd, 0, vrWin.Left, vrWin.Top, vrWin.Right - vrWin.Left, _
vrWin.Bottom - vrWin.Top, SWP_FRAMECHANGED
End Sub
Private Sub CommandButton1_Click()
'Démarrer
Sablier.Show vbModeless
End Sub
Private Sub CommandButton2_Click()
'Terminer
Animer = False
End Sub
Erreur système &H80004005 (-2147467259). Erreur non spécifiée
If Dir(MonRepertoir) = "" Then
'Le répertoir n'existe pas ou n'est pas bien libellé
End If
Public Function TestSiVide(Rep As String) As Long
Dim Obj, RepP, F
On Error GoTo Faute 'Si le répertoir n'est pas trouvé
Set Obj = CreateObject("Scripting.FileSystemObject")
Set RepP = Obj.Getfolder(Rep)
Set F = RepP.Files
TestSiVide = F.Count
Set RepP = Nothing
Set F = Nothing
Sortie:
Set Obj = Nothing
Exit Function
Faute:
TestSiVide = -1
Resume Sortie 'Le Resume est nécessaire pour éviter des noeux dans la pile.
End Function
Sub Test(Rep as String)
Dim Nb As Long, MonRepertoir as String
If Rep <> "" Then
MonRepertoir = Rep & IIf(Right(Rep, 1) <> "\", "\", "") ' Eventuellement ajouter le slasch inverse
Nb = TestSiVide(MonRepertoir ) 'Renvoi -1 si erreur de répertoir (erreur 76)
If Nb = 0 Then
MsgBox "Le répertoir sélectionné ne contient pas de fichier ", vbCritical, "Sélection répertoir"
ElseIf Nb = -1 Then
MsgBox "Le répertoir sélectionné n'est pas/plus valide", vbCritical, "Sélection répertoir"
Else
MsgBox "Le répertoir sélectionné est valide"
End If
End If
End Sub
C'est une procédure qui permet de créer le classeur pour regrouper ses macros et fonctions personnelles dans un fichier commun qui est ouvert au démarrage d'Excel. Ainsi cela permet d'utiliser ses macros depuis n'importe quel classeur même s'il ne comporte pas de macros en son sein.
Option Explicit
Sub SepareAdresse()
Dim WkSource As Worksheet, WkDest As Worksheet
Dim Colsource As Integer, LigSource As Integer, Lig As Long, UB As Byte
Dim ColDest As Integer, LigDest As Long, TB, i As Integer, e As Integer
Dim OrdreDest()
Set WkSource = Sheets("Feuil1") 'Feuille où se trouve les adresses à séparer
'Note : si les adresses sont dans un autre classeur vous pouvez initialiser par
'Set WkSource = Workbooks("ClasseurSource.xls").Sheets("Feuil1")
Colsource = 2 'colonne où se trouve les adresses à séparer - ici "B"
LigSource = 4 'Première ligne où se trouve les adresses à séparer - ici "4"
Set WkDest = Sheets("Feuil2") 'Feuille où mettre les données séparées
'Note : si les destinations sont dans un autre classeur vous pouvez initialiser par
'Set WkDest = Workbooks("ClasseurDest.xls").Sheets("Feuil2")
ColDest = 3 'Première colonne où mettre les adresses séparées - ici "C"
LigDest = 3 'Première ligne où mettre les adresses séparées
'Changer l'ordre des cellules
'Exemple pour avoir
'rue des Abeilles | 143 | Bt 3 | 65677 | LaVille
OrdreDest = Array(1, 0, 2, 3, 4)
'Dans l'exemple nous ne modifierons pas l'ordre des colonnes,
'Si il y a des adresses avec et sans boite postale, sélectionnez 4 colonnes
OrdreDest = Array(0, 1, 2, 3, 4)
'S'il n' y a jamais de BP, mettre une colonne en moins
'OrdreDest = Array(0, 1, 2, 3)
With WkSource
For Lig = LigSource To .Cells(65536, Colsource).End(xlUp).Row
On Error GoTo Erreur ' au cas où une adresse serait invalide
TB = Split(.Cells(Lig, Colsource), " ")
UB = UBound(TB)
For i = 1 To UB
If Not IsNumeric(TB(i + 1)) Then
If i > 1 Then TB(1) = TB(1) & " " & TB(i)
Else
Exit For
End If
Next i
If UBound(TB) < 4 Then
ReDim Preserve TB(4)
TB(4) = TB(3): TB(3) = TB(2)
End If
If TB(i + 1) < 300 Then 'il y a une boite postale
If UBound(OrdreDest) = 4 Then
TB(2) = TB(i) & " " & TB(i + 1)
TB(3) = TB(i + 2): TB(4) = TB(i + 3)
Else 'mais il ne faut pas l'afficher
TB(2) = TB(UBound(TB) - 1): TB(3) = TB(UBound(TB))
End If
Else ' pas de boite postale
If i > 1 Then TB(1) = TB(1) & " " & TB(i)
If UBound(OrdreDest) = 4 Then 'la BP est optionnelle mais n'est pas présente
TB(2) = ""
TB(3) = TB(UBound(TB) - 1): TB(4) = TB(UBound(TB))
Else
TB(2) = TB(UBound(TB) - 1): TB(3) = TB(UBound(TB))
End If
End If
For e = 0 To UBound(OrdreDest)
WkDest.Cells(LigDest, ColDest).Offset(, OrdreDest(e)) = TB(e)
Next e
LigDest = LigDest + 1
Passe:
Next Lig
End With
Exit Sub
Erreur:
Resume Passe
End Sub
NB : Procédure proposée le 24/07/09 à 09:24 par jaaloor. Merci à lui !
Sheets(F).Visible = Falsepar
Sheets(F).Visible = xlSheetVeryHidden
Option Explicit
Sub CréerCombo(Lier As Range, Optional Sh As Worksheet, Optional Emplacement As Range)
Dim Obj As Object
Dim code As String
Dim Ix As Integer, Num As String
If Sh Is Nothing Then
Set Sh = ActiveSheet
End If
Sh.Select
Ix = ActiveSheet.OLEObjects.Count + 1
Num = "0" & Ix: Num = Right(Num, 2) 'Pour jusque 99 boutons
If Emplacement Is Nothing Then
'emplacement par défaut
Set Emplacement = ActiveCell
End If
'crée le bouton
With Emplacement
Set Obj = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Combobox.1", _
Link:=False, DisplayAsIcon:=False, Left:=.Left, Top:=.Top, Width:=.ColumnWidth * 5.65, Height:=.RowHeight)
Obj.Name = "ComboB_" & Num
End With
'propriétés du combo
With ActiveSheet.OLEObjects(Ix)
.Placement = xlMoveAndSize
.PrintObject = True
.ListFillRange = Lier.Address
End With
'Le texte de la macro
code = vbCrLf & "Private Sub ComboB_" & Num & "_Change()" & vbCrLf
code = code & " MsgBox ""Vous avez sélectionner la ligne "" & ComboB_" & Num & ".Text , ,""ComboB_" & Num & """" & vbCrLf
code = code & "End Sub"
'Ajoute la macro en fin de module feuille
With ActiveWorkbook.VBProject.VBComponents(ActiveSheet.Name).CodeModule
.insertlines .CountOfLines + 1, code
End With
End Sub
Pour créer le support de cette démo j'ai employé mon exemple de la calculatrice mais en créant tous les contrôles de façon dynamique.
Dim DernLigne As Long
DernLigne = Range("A65536").End(xlUp).Row
Dim DernLigne As Long
DernLigne = Range("A1048576").End(xlUp).Row
Dim DernLigne As Long
DernLigne = Columns(1).Find("*", , , , xlByColumns, xlPrevious).Row
Dim DernLigne As Long
DernLigne = Range("A" & Rows.Count).End(xlUp).Row
Dim DernCol As Integer DernCol = Cells(1, Cells.Columns.Count).End(xlToLeft).Column
Pour les adeptes d'Excel en Anglais, voici la traduction des fonctions "principales" du Français à l'Anglais. Et réciproquement...
Français ====> Anglais ABS ====> ABS ACOS ====> ACOS ACOSH ====> ACOSH ADRESSE ====> ADDRESS ALEA ====> RAND AMORLIN ====> SLN ANNEE ====> YEAR ARGUMENT ====> ARGUMENT ARRONDI ====> ROUND ASIN ====> ASIN ASINH ====> ASINH ATAN ====> ATAN ATAN2 ====> ATAN2 ATANH ====> ATANH AUJOURDHUI ====> TODAY BDECARTYPE ====> DSTDEV BDECARTYPEP ====> DSTDEVP BDMAX ====> DMAX BDMIN ====> DMIN BDMOYENNE ====> DAVERAGE BDNB ====> DCOUNT BDNBVAL ====> DCOUNTA BDPRODUIT ====> DPRODUCT BDSOMME ====> DSUM BDVAR ====> DVAR BDVARP ====> DVARP CAR ====> CHAR CELLULE ====> CELL CHERCHE ====> SEARCH CHOISIR ====> CHOOSE CNUM ====> VALUE CODE ====> CODE COLONNE ====> COLUMN COLONNES ====> COLUMNS COS ====> COS COSH ====> COSH CROISSANCE ====> GROWTH CTXT ====> FIXED DATE ====> DATE DATEVAL ====> DATEVALUE DB ====> DB DDB ====> DDB DECALER ====> OFFSET DEGRES ====> DEGREES DETERMAT ====> MDETERM DROITE ====> RIGHT DROITEREG ====> LINEST ECARTYPE ====> STDEV ECARTYPEP ====> STDEVP ENT ====> INT EPURAGE ====> CLEAN EQUIV ====> MATCH ESTERR ====> ISERR ESTERREUR ====> ISERROR ESTLOGIQUE ====> ISLOGICAL ESTNA ====> ISNA ESTNONTEXTE ====> ISNONTEXT ESTNUM ====> ISNUMBER ESTREF ====> ISREF ESTTEXTE ====> ISTEXT ESTVIDE ====> ISBLANK ET ====> AND EXACT ====> EXACT EXP ====> EXP FACT ====> FACT FONCTION.APPELANTE ====> CALL FRANC ====> DOLLAR GAUCHE ====> LEFT HEURE ====> HOUR INDEX ====> INDEX INDIRECT ====> INDIRECT INFO ====> INFO INTPER ====> IPMT INVERSEMAT ====> MINVERSE JOUR ====> DAY JOURS360 ====> DAYS360 JOURSEM ====> WEEKDAY LIGNE ====> ROW LIGNES ====> ROWS LN ====> LN LOG ====> LOG LOG10 ====> LOG10 LOGREG ====> LOGEST MAINTENANT ====> NOW MAJUSCULE ====> UPPER MAX ====> MAX MEDIANE ====> MEDIAN MIN ====> MIN MINUSCULE ====> LOWER MINUTE ====> MINUTE MOD ====> MOD MOIS ====> MONTH MOYENNE ====> AVERAGE N ====> N NB ====> COUNT NB.SI ====> COUNTIF NB.VIDE ====> COUNTBLANK NBCAR ====> LEN NBVAL ====> COUNTA NOMPROPRE ====> PROPER NON ====> NOT NPM ====> NPER OU ====> OR PI ====> PI PRINCPER ====> PPMT PRODUIT ====> PRODUCT PRODUITMAT ====> MMULT RACINE ====> SQRT RADIANS ====> RADIANS RANG ====> RANK RECHERCHE ====> LOOKUP RECHERCHEH ====> HLOOKUP RECHERCHEV ====> VLOOKUP REGISTRE.NUMERO ====> REGISTER.ID REMPLACER ====> REPLACE REPT ====> REPT SECONDE ====> SECOND SI ====> IF SIGNE ====> SIGN SIN ====> SIN SINH ====> SINH SOMME ====> SUM SOMME.SI ====> SUMIF SOMMEPROD ====> SUMPRODUCT SOUS.TOTAL ====> SUBTOTAL STXT ====> MID SUBSTITUE ====> SUBSTITUTE SUPPRESPACE ====> TRIM SYD ====> SYD T ====> T TAN ====> TAN TANH ====> TANH TAUX ====> RATE TEMPS ====> TIME TEMPSVAL ====> TIMEVALUE TENDANCE ====> TREND TEXTE ====> TEXT TRANSPOSE ====> TRANSPOSE TRI ====> IRR TRIM ====> MIRR TRONQUE ====> TRUNC TROUVE ====> FIND TYPE ====> TYPE TYPE.ERREUR ====> ERROR.TYPE VA ====> PV VAN ====> NPV VAR ====> VAR VAR.P ====> VARP VC ====> FV VDB ====> VDB VPM ====> PMT ZONES ====> AREAS