Astuce du jour: Palette de couleur sur le click droit

Sub Combien_Lignes_Colonnes_Feuille_Supprime_Lignes_Vides_Basses()
'MJ
    t1 = Timer

    Dim DerLigRempli(16384) 'As Long
    DerL = [A1].SpecialCells(xlLastCell).Row
    DerC = [A1].SpecialCells(xlLastCell).Column

    For i = 1 To DerL
        If Application.WorksheetFunction.CountA(Range(Cells(i, 1), Cells(i, Columns.Count))) > 0 Then NbligRempli = NbligRempli + 1
    Next

    For j = 1 To DerC
        If Application.WorksheetFunction.CountA(Range(Cells(1, j), Cells(Rows.Count, j))) > 0 Then NbColRempli = NbColRempli + 1
    Next
    
    'Suppresion des lignes vides après la dernière ligne
    DerligRenseignee = Cells(Rows.Count, 1).End(xlUp).Row
    For k = 1 To DerC
        DerLigRempli(k) = Cells(Rows.Count, k).End(xlUp).Row
        If DerLigRempli(k) > DerligRenseignee Then DerligRenseignee = DerLigRempli(k)
    Next
    
    'MsgBox DerligRenseignee
    Rows(DerligRenseignee + 1 & ":" & Rows.Count).Delete
    ActiveWorkbook.Save
    
    t2 = Timer - t1

    MsgBox DerC & " colonnes" & " dont " & NbColRempli & " Colonnes remplies." & Chr(10) & DerL & " lignes " & " dont " & NbligRempli & " lignes remplies." & Chr(10) & "Durée de traitement: " & Format(t2, "0.0") & "secondes" & Chr(10) & "La dernière ligne renseignée est la ligne: " & DerligRenseignee


End Sub

Sub Google_Recherche_Rapide()
    NAT = InputBox("Nom à rechercher sur Google.fr", , "Windows 8.1")
    NAT2 = InputBox("Durée (h,d,w,m,y)", , "h")
    ActiveWorkbook.FollowHyperlink "http://www.google.fr/#lr=lang_fr&q=" & NAT & "&safe=active&tbs=lr:lang_1fr,qdr:" & NAT2
End Sub

Private Sub CommandButton6_Click() 'Trier
Dim Nb%, Col%
Dim Motif$

Col = 16
Nb = Cells(1, 19).Value
Motif = CommandButton6.Caption
'------- Tri A-Z ----------
If Motif = "Trie A-Z" Then
    Range(Cells(2, Col), Cells(Nb + 1, Col + 2)).Select
    ActiveCell.Sort key1:=Cells(2, Col), order1:=xlAscending, Header:=xlGuess
    CommandButton6.Caption = "Trie Z-A"
    CommandButton6.BackColor = RGB(250, 100, 100)
    Cells(1, 10).Select
ElseIf Motif = "Trie Z-A" Then
    Range(Cells(2, Col), Cells(Nb + 1, Col + 2)).Select
    ActiveCell.Sort key1:=Cells(2, Col), order1:=xlDescending, Header:=xlGuess
    CommandButton6.Caption = "Trie A-Z"
    CommandButton6.BackColor = RGB(100, 250, 100)
    Cells(1, 10).Select
End If
'Call ChargementListBox
End Sub

Public Valeur
Sub Tri_Feuille_Global_Asc_Desc()
'Attention tri par rapport au tableau de la première ligne sans colonne ou ligne vide
'Faire Ctrl* pour voir le tableau sélectionné avant de lancer la macro
    Feuille = ActiveSheet.Name
    Zone = ActiveCell.CurrentRegion.Address
    N = ActiveCell.Column
    L = ActiveCell.Row
    'Derl = ActiveWorkbook.Worksheets(Feuille).Cells(Rows.Count, 1).End(xlUp).Row
    ActiveWorkbook.Worksheets(Feuille).Sort.SortFields.Clear
    If Valeur = False Then ActiveWorkbook.Worksheets(Feuille).Sort.SortFields.Add Key:=Range(Cells(L, N).Address), _
       SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers Else ActiveWorkbook.Worksheets(Feuille).Sort.SortFields.Add Key:=Range(Cells(L, N). _
                                                                                                                                                       Address), SortOn:=xlSortOnValues, Order:=xlDescending _
                                                                                                                                                                                                   , DataOption:=xlSortTextAsNumbers

    With ActiveWorkbook.Worksheets(Feuille).Sort
        .SetRange Range(Zone)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    If Valeur = True Then Valeur = False:  Exit Sub
    If Valeur = False Then Valeur = True: Exit Sub
End Sub

Public Valeur

Sub Tri_Feuille_Global_Asc_Desc()
'Attention tri par rapport au tableau de la première ligne sans colonne ou ligne vide
'Faire Ctrl* pour voir le tableau sélectionné avant de lancer la macro
    Feuille = ActiveSheet.Name
    Zone = ActiveCell.CurrentRegion.Address
    N = ActiveCell.Column
    L = ActiveCell.Row
    'Derl = ActiveWorkbook.Worksheets(Feuille).Cells(Rows.Count, 1).End(xlUp).Row

    ActiveWorkbook.Worksheets(Feuille).Sort.SortFields.Clear

    If Valeur = False Then
        ActiveWorkbook.Worksheets(Feuille).Sort.SortFields.Add Key:=Range(Cells(L, N).Address), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    ElseIf Valeur = True Then
          ActiveWorkbook.Worksheets(Feuille).Sort.SortFields.Add Key:=Range(Cells(L, N).Address), _
          SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortTextAsNumbers
    End If


    With ActiveWorkbook.Worksheets(Feuille).Sort
        .SetRange Range(Zone)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    If Valeur = True Then Valeur = False:  Exit Sub
    If Valeur = False Then Valeur = True: Exit Sub
End Sub

Dim n As Byte
Sub t()
  n = IIf(n = 1, 2, 1)
  [Plage].Sort Cells(1, ActiveCell.Column), n, Header:=1
End Sub

Dim n As Byte
 Sub Tri()
   n = IIf(n = 1, 2, 1)
   Range(ActiveCell.CurrentRegion.Address).Sort Cells(1, ActiveCell.Column), n, Header:=1
 End Sub

Sub ResolutionEcran()
strComputer = "."
Set objWMIService = GetObject( _
    "winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.Execquery( _
    "Select * from Win32_DesktopMonitor")
For Each objItem In colItems
    MsgBox "Résolution de l'écran : " & objItem.ScreenHeight & " x " & _
    objItem.ScreenWidth & vbCrLf
Next
Set objWMIService = Nothing
Set colItems = Nothing
End Sub