MaValeur = Application.Evaluate("LOG(A1*3+2)")

MaValeur = [LOG(A1*3+2)]

 
objSheet.UsedRange.NumberFormat = "0;-0;;@"

 
Dim ObjCell As Range

For Each ObjCell In Range("A1:J65535").Cells
    ObjCell.Value = ObjCell.Value * 2 + 3
Next

 
Dim Montab As Variant, cmpt1 As Long, cmpt2 As Long

Montab = Range("A1:J65535").Value

For cmpt1 = LBound(Montab, 1) To UBound(Montab, 1)
    For cmpt2 = LBound(Montab, 2) To UBound(Montab, 2)
        Montab(cmpt1, cmpt2) = Montab(cmpt1, cmpt2) * 2 + 3
    Next cmpt2
Next cmpt1

Range("A1:J65535").Value = Montab

Range("F29:F30").AutoFill Destination:=Range("F29:F43"), Type:=xlGrowthTrend
Cells(29, 6).Resize(2).AutoFill Destination:=Cells(29, 6).Resize(10), Type:=xlFillDefault

 
Cells(29, 6).Resize(10).FillDown

Range("A1:A10").SpecialCells(xlCellTypeConstants, 3).ClearContents

With Range("G1").Validation
        .Add Type:=xlValidateWholeNumber, AlertStyle:=xlValidAlertStop, _
        Operator:=xlBetween, Formula1:="10", Formula2:="100"
        .IgnoreBlank = True
        .InCellDropdown = True
        .ErrorMessage = "La valeur doit être comprise entre 10 et 100"
        .ShowInput = True
        .ShowError = True
End With

Sub Test()
    ProtectionCellules_Formules Worksheets("Feuil3"), "DVP"
End Sub


Sub ProtectionCellules_Formules(Ws As Worksheet, PassWord As String)
    On Error Resume Next
    
    With Ws
        .Unprotect PassWord 'Le mot de passe est en option
        .Cells.Locked = False
        .Cells.SpecialCells(xlCellTypeFormulas).Locked = True
        .EnableSelection = xlUnlockedCells
        .Protect PassWord
    End With
End Sub

Sub Deprotege()
    Worksheets("Feuil3").Unprotect "DVP"
End Sub

Dim NbLignes As Integer    
NbLignes = ActiveSheet.UsedRange.Rows.Count

Dim LaPremiereLigne As Integer    
LaPremiereLigne = ActiveSheet.UsedRange.Row

Dim DerniereLigne As Integer    
DerniereLigne = Range(Cel).CurrentRegion.End(xlDown).Row

Dim strPlage As String    
strPlage = Range("A15").CurrentRegion.Address(False, False)  
'Exemple : "A4:N25"

Dim DerniereLigne As Integer    
DerniereLigne = Range("A65536").End(xlUp).Row

Dim DerniereLigne As Integer    
DerniereLigne = Range("A1").End(xlDown).Row

Dim DerniereLigne As Integer    
DerniereLigne = Range("C15").End(xlDown).Row

Dim DerniereLigne As Integer    
DerniereLigne = Range("A1").SpecialCells(xlCellTypeLastCell).Row

Dim AdresseAbsolue As String    
AdresseAbsolue = Range("A1").SpecialCells(xlCellTypeLastCell).Address

    DerniereColonne = ActiveSheet.UsedRange.Columns.Count
    DernièreColonne = Selection.CurrentRegion.End(xlToRight).Column
    DerniereColonne = Range("A1").End(xlToRight).Column
    DerniereColonne = Range("IV1").End(xlToLeft).Column
    'où IV est la dernière colonne d'une feuille de calculs => 256)
    DerniereColonne = Range("A1").SpecialCells(xlCellTypeLastCell).Column

Dim strPlage As String
strPlage = Range(Cells(1,1), Cells(Range("A65536").End(xlUp).Row, _
                Range("IV1").End(xlToLeft).Column)).Address

Dim objPlage As Range
Set objPlage = Range(Cells(1,1), Cells(Range("A65536").End(xlUp).Row, _
                Range("IV1").End(xlToLeft).Column))

Dim strPlage As String
srtPlage = Range("A1:" & Range("A1").SpecialCells(xlCellTypeLastCell).Address).Address

Range("A1:" & Range("A1").SpecialCells(xlCellTypeLastCell).Address).select

'Extrait les données séparées par un espace dans la cellule A1
Sub extractionMots()
    Dim Tableau() As String
    Dim i As Integer
    
    'découpe la chaine en fonction des espaces " "
    'le résultat de la fonction Split est stocké dans un tableau
    Tableau = Split(Range("A1"), " ")
    
    'boucle sur le tableau pour visualiser le résultat
    For i = 0 To UBound(Tableau)
        'Le résultat s'affiche dans la premiere ligne, à
        'partir de la cellule B1.
        Range("A1").Offset(0, i + 1) = Tableau(i)
    Next i
End Sub

Sub Test()
    Deplace Range("K20")
End Sub
 
 
'Positionne la cellule spécifiée dans le coin supérieur gauche
'de l'application.
Sub Deplace(Cellule As Range)
    Dim Ligne As Integer, Colonne As Integer
    
    Ligne = Cellule.Row
    Colonne = Cellule.Column
    
    With ActiveWindow
        .ScrollRow = Ligne
        .ScrollColumn = Colonne
    End With
End Sub

Sub VisualiserCellulesFusionnees()
Dim Cell As Range

'Boucle sur les cellules utilisées dans la feuille
For Each Cell In Worksheets("Feuil1").UsedRange.Cells
    'Si la cellule est fusionnée
    'Colorie en jaune si la cellule est fusionnée
    If Cell.MergeCells Then Cell.MergeArea.Interior.ColorIndex = 6
Next Cell
End Sub

Option Explicit
 
Sub Test()
    'Liste les dépendants de la cellule D4, dans la Feuil2
    ListeDependents Worksheets("Feuil2").Range("D4")
End Sub
 
 
Sub ListeDependents(Cellule As Range)
    Dim Ws As Worksheet
    Dim Plage As Range, Cell As Range, DirectDep As Range
    Dim i As Integer, x As Integer
    Dim Cible As String, strDepenDent As String, strRefer As String
    'La liste des dépendants  va être stockée dans une collection
    Dim Un As New Collection
    
    
    'Active la feuille contenant la cellule à contrôler
    Cellule.Parent.Activate
    
    strDepenDent = Cellule.Parent.Name & "!" & Cellule.Address(0, 0)
        
        
    'Vérifie s'il y a des dépendants directs dans la feuille:
    On Error Resume Next
    'Définit la plage de cellules dépendantes, dans la feuille active
    Set Plage = Cellule.DirectDependents.Cells
    On Error GoTo 0
    
    If Not Plage Is Nothing Then
        'Boucle sur les dépendants contenus dans la feuille active
        For Each DirectDep In Cellule.DirectDependents.Cells
            Un.Add Cellule.Parent.Name & "!" & DirectDep.Address, _
                Cellule.Parent.Name & "!" & DirectDep.Address
        Next DirectDep
    End If
    
    Set Plage = Nothing
    
    
    
    'Boucle sur les autres feuilles du classeur:
    For Each Ws In ThisWorkbook.Worksheets
        'Si la feuille est différente de la feuille active
        If Ws.Name <> Cellule.Parent.Name Then
            
            On Error Resume Next
            'Définit la plage de cellules contenant des formules
            Set Plage = Ws.UsedRange.SpecialCells(xlCellTypeFormulas)
            On Error GoTo 0
            
            
            'Vérifie si la feuille contient des formules
            If Not Plage Is Nothing Then
                
                'Boucle sur les cellules contenant des formules
                For Each Cell In Plage
                        
                    'Gestion des références relatives et absolues
                    Cible = Replace(Cell.Formula, "$", "")
                        
                        
                    'Vérifie si le nom de la feuille apparait dans la formule.
                    If InStr(1, Cible, Cellule.Parent.Name) > 0 Then
                        
                        'Vérifie si la formule contient une référence correspondant à la
                        'cellule à contrôler
                        i = 0
                        i = InStr(1, Cible, strDepenDent)
                        
                        'Si la référence est trouvée on l'intègre dans la collection
                        If i > 0 And Not IsNumeric(Mid(Cible, i + Len(strDepenDent), 1)) Then
                            
                            Un.Add Ws.Name & "!" & Cell.Address, Ws.Name & "!" & Cell.Address
                        
                        Else
                            
                            'Recherche des références dans les plages de cellules
                            For x = 1 To Len(Cible)
                                i = 0
                                i = InStr(1, Cible, ":")
                                
                                If i > 0 Then
                                    strRefer = ExtractionReferences(Cible)
                                    
                                    'Si la cellule à contrôler se trouve dans la plage,
                                    'on l'intègre dans la collection.
                                    If VerifIntersect(Cellule, Range(strRefer)) And _
                                        InStr(1, Cible, Cellule.Parent.Name & "!" & strRefer) > 0 Then
                                        
                                        On Error Resume Next
                                        Un.Add Ws.Name & "!" & Cell.Address, Ws.Name & "!" & Cell.Address
                                        On Error GoTo 0
                                        
                                        Exit For
                                    End If
                                    
                                    Cible = Mid(Cible, i + 1)
                                Else
                                    Exit For
                                End If
                            Next x
                            '--------------
                        
                        
                        End If
                    End If
                Next Cell
                
            End If
        End If
    
        Set Plage = Nothing
    Next Ws
 
    
    'Boucle sur la collection qui contient la liste des dépendants
    For i = 1 To Un.Count
        'Affiche le résultat dans la fenêtre d'exécution (Ctrl+G)
        Debug.Print Un.Item(i)
    Next i
End Sub
 
 
 
 
'Extrait les références spécifiées dans les formules
Function ExtractionReferences(Chaine As String) As String
    Dim i As Integer, j As Integer
    Dim strPlage As String, Caract As String
    
    i = InStr(1, Chaine, ":")
                        
                        
    'Renvoie la référence avant les deux points ":"
    For j = i - 1 To 1 Step -1
        Caract = Mid(Chaine, j, 1)
        
        Select Case Asc(Caract)
            Case 48 To 57, 65 To 90, 97 To 122
            strPlage = Caract & strPlage
            Case Else: Exit For
        End Select
    Next j
    
    strPlage = strPlage & ":"
    
    'Renvoie la référence après les deux points ":"
    For j = i + 1 To Len(Chaine)
        Caract = Mid(Chaine, j, 1)
        
        Select Case Asc(Caract)
            Case 48 To 57, 65 To 90, 97 To 122
            strPlage = strPlage & Caract
            Case Else: Exit For
        End Select
    Next j
    
    ExtractionReferences = strPlage
End Function
 
 
 
'Vérifie si la référence extraite dans la formule a une intersection
'avec la cellule dont on contrôle les dépendances.
Function VerifIntersect(objDepend As Range, objReference As Range) As Boolean
    Dim objRange As Range
    
    Set objRange = Intersect(objDepend, objReference)
    
    If objRange Is Nothing Then
        VerifIntersect = False
        Else
        VerifIntersect = True
    End If
End Function

' --- Dans le module objet du classeur:
Option Explicit

'évènement ouverture du classeur.
Private Sub Workbook_Open()
    'Lance la procédure
    GetTempo
End Sub

'Avant la fermeture du classeur:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    'Désactive la procédure de temporisation
    Application.OnTime EarliestTime:=Now, Procedure:="GetTempo", Schedule:=False
End Sub

' --- Dans un module standard:
Option Explicit

Dim vTempo As Boolean
 
Sub GetTempo()
    vTempo = Not vTempo
    Application.OnTime Now + TimeValue("00:00:01"), "GetTempo"
    [Feuil1!A1] = vTempo
End Sub

Sub DoCmdRunSQL(ByVal sql As String, ByVal rDest As Range)
 
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    
    Set db = DAO.OpenDatabase(ActiveWorkbook.FullName, False, False, "Excel 8.0;HDR=YES;")
    Set rs = db.OpenRecordset(sql, DAO.dbOpenSnapshot)
    rDest.CopyFromRecordset rs
    Set rs = Nothing
    Set db = Nothing
    
End Sub

DoCmdRunSQL "SELECT * FROM [feuil1$A3:D600] WHERE age > 18", sheets("Résultat").range("A1")

Sub Test()
    Dim Cible As Range
    
    'Effectue la recherche dans la feuille active
    Set Cible = DerniereCellule(ActiveSheet)
    
    If Not Cible Is Nothing Then
        MsgBox Cible.Address & vbCrLf & Cible.Value
        Else
        MsgBox "La feuille est vide."
    End If
End Sub


Function DerniereCellule(Ws As Worksheet) As Range
    Dim NumLigne As Double, NumCol As Integer
    
    'Vérification si la feuille est totalement vide
    If Ws.UsedRange.Cells.Address = "$A$1" And _
        IsEmpty(Ws.Range("A1")) Then Exit Function
    
    With Ws
        'Identifie le numéro de ligne
        NumLigne = .Cells.Find("*", .Range("A1"), , , xlByRows, xlPrevious).Row
        'Identfie le numéro de colonne
        NumCol = .Cells.Find("*", .Range("A1"), , , xlByColumns, xlPrevious).Column
        
        Set DerniereCellule = .Cells(NumLigne, NumCol)
    End With
End Function

Dim Plage1 As Range
Set Plage1 = Range("A1").CurrentRegion
MsgBox Plage1.Parent.Name & "!" & Plage1.Address

Dim Plage1 As Range
Set Plage1 = Range("A1").CurrentRegion
MsgBox Plage1.Worksheet.Name & "!" & Plage1.Address

Sub Degrade()
 
    Dim strAddr As String, strAddrRC As String
    Dim cell As Range, c As Range
    
    
    For Each cell In Selection.Cells
        If cell.MergeCells Then
            'cellule fusionnée
            If cell.Address = cell.MergeArea.Cells(1).Address Then
                Set c = cell.MergeArea
            Else
                ' cas où le cadre a déjà été tracé
                GoTo nextCell
            End If
        Else
            Set c = cell
        End If
    
        strAddrRC = c.Address(True, True, xlR1C1, False)
        strAddr = c.Address(False, False, xlA1, False)
        With c
            ActiveSheet.Shapes.AddShape(msoShapeRectangle, .Left, .Top, .Width, .Height).Select
        End With
        
        ' dégradé
        Selection.ShapeRange.Line.Visible = msoFalse
        Selection.ShapeRange.Fill.Visible = msoTrue
        Selection.ShapeRange.Fill.ForeColor.RGB = Range(strAddr).Cells(1).Interior.Color
        Selection.ShapeRange.Fill.OneColorGradient msoGradientHorizontal, 1, 0.39
        
        ' texte
        ExecuteExcel4Macro "FORMULA(""=" & strAddrRC & """)"
    
        ' alignement
        On Error Resume Next
        With Selection
            If IsNumeric(c.Value) Then
                .HorizontalAlignment = xlRight
            Else
                .HorizontalAlignment = c.HorizontalAlignment
            End If
            .VerticalAlignment = c.VerticalAlignment
            .ReadingOrder = c.ReadingOrder
            .Orientation = c.Orientation
            .AutoSize = False
            With .Font
                .Name = c.Font.Name
                .Size = c.Font.Size
                .ColorIndex = c.Font.ColorIndex
                .Underline = c.Font.Underline
                .Italic = c.Font.Italic
                .Bold = c.Font.Bold
            End With
        End With
        On Error GoTo 0
nextCell:
    Next cell
    
    Set c = Nothing
    Set cell = Nothing
End Sub

Private Function EnleveAccents(ByVal Chaîne As String) As String

    Dim compteur As Long, CarLu As String, ValRet As Integer
    For compteur = 1 To Len(Chaîne)
        CarLu = Mid(Chaîne, compteur, 1)
        ValRet = Asc(CarLu)
        Select Case ValRet
            Case 192 To 197: ValRet = 65
            Case 200 To 203: ValRet = 69
            Case 204 To 207: ValRet = 73
            Case 210 To 214: ValRet = 79
            Case 218 To 220: ValRet = 85
            Case 224, 226, 228: ValRet = 97
            Case 232 To 235: ValRet = 101
            Case 238, 239: ValRet = 105
            Case 244, 246: ValRet = 111
            Case 251, 252: ValRet = 117
        End Select
        EnleveAccents = EnleveAccents & Chr(ValRet)
    Next
    
End Function

Case 192 To 197: ValRet = 65

Case 192 To 197
    ValRet = 65

Application.AddCustomList Array("Blanc", "Vert", "Rouge", "Bleu", "Noir")
 

 
Application.AddCustomList Range("A1:A10")