Astuce du jour: Palette de couleur sur le click droit

[MJ13]

Astuce du jour: Copier Coller Valeur Format...

Bonjour à tous

Voici le plan des différentes astuces présentes dans cette discussion (Mise à Jour le 21 03 2014):

Encadre Tableau

Mise en page feuille

Redimensionnement d'images

Capture Ecran

Encadrement tableau

Tri Tableau

Installer sur Win8 64 bits programmes anciens

Lancer nouvelle instance d'Excel

Astuces pour le forum

Supprimer les lignes en trop

Recherche Rapide Google

Tri Ascendant Descendant

Range Dossier suivant extension des fichiers V1 et V2


Résolution Ecran


Palette de couleur sur le click droit

Programmer le Bouton Marche/Arrêt

Résoudre le problème des Litviews

Copier Coller valeur format...


Quand , on programme en VBA, avec l'enregistreur de macros, on a souvent des lignes de codes superflues .

En essayant de trouver un moyen simple pour encadrer un tableau de toutes les cellules on peut écrire:

Code VBA:
Selection.Borders.LineStyle = xlContinuous




Au lieu de:


Code VBA:
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With




Je voulais le partager avec vous pour une fois que je trouve une astuce intéressante .

 

[Staple1600]

Re : Astuce du jour: Encadrement tableau VBA

Bonsoir à tous

MJ13

j'ai bien essayé de mettre Higlight comme tu le préconises

Moi ce que je préconisais c'est Highlight

Mais je devrais changer ma signature et opter pour la voie Modeste, qui elle aussi mène vers la Haute Lumière du VBA Sacré.

 

[MJ13]

Re : Astuce du jour: Encadrement tableau VBA

Bonjour à tous

Moi ce que je préconisais c'est Highlight

Merci Jean-Marie. Ah, c'est pour ça, j'avais bien essayé twilight, mais j'avais une tête avec de grosses canines .

Sinon, Merci aussi à Modeste GD, ta solution est parfaite, je l'adopte (Pas MGD ), en plus c'est pas trop compliqué à retenir en cliquant sur le bouton code adéquate en réponse avancé.

 

[MJ13]

Re : Astuce du jour: Supprimer les lignes en trop

Bonjour à tous

Un des problèmes sur Excel est que souvent, on peut avoir plus de lignes que de données (qu'on peut contrôler avec Ctrl+Fin).

Cette macro permet de vérifier le nombres de lignes prises en compte et réelllement remplies et de supprimer les lignes vides qui sont prises en compte après la dernière ligne remplie.

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

 

[MJ13]

Re : Supprimer les lignes en trop

Bonjour à tous

Suite à une intervention de David (David84), la macro précédente peut présenter des problèmes si on a des lignes masquées en fin de tableau. Cette macro le corrige en mettant toutes les lignes visibles de façon à avoir l'ensemble des données visibles lors de la réouverture du fichier.

Code VBA:
Sub Combien_Lignes_Colonnes_Feuille_Supprime_Lignes_Vides_Basses()
'MJ
t1 = Timer
'MsgBox ActiveSheet.FilterMode
'MsgBox ActiveSheet.AutoFilterMode
If ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
Cells.Select
Cells.EntireRow.AutoFit
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
'A décommenter en cas de besoin
'MsgBox DerligRenseignee
'Supprime les lignes vides sous les denières données
Rows(DerligRenseignee + 1 & ":" & Rows.Count).Delete
'Sauvegarde le fichier actif
'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

 

[MJ13]

Re : Astuce du jour: Recherche Rapide Google

Bonjour à tous

Voici une petite macro sur Excel pour facilement faire une recherche sur google en chosissant ses paramètres, en français et pouvoir choisir la durée pour la recherche plus ou moins longue.

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

 

[VIARD]

Re : Astuce du jour: Recherche Rapide Google

Bonjour MJ13 et à Tous

Comme les astuces y vont de bon coeur.
Je vous propose un trie montant et descendant sur un seul bouton.
Je l'utilise un peu partout, à adapter.

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

Jean-Paul

 

[MJ13]

Re : Astuce du jour: Tri Ascendant descendant

Bonjour à tous

Merci Jean-Paul pour ta participation.

Cela tombe à point, car j'ai redeveloppé le tri ascendant et descendant sur la colonne en cours qui s'adapte à la plage du tableau, je l'ai optimisé au maximum.

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

 

[VIARD]

Re : Astuce du jour: Tri Tableau Ascendant Descendant

Bonjour MJ13 et à tous

Merci MJ13, ton truc est super génial.
Mais comme j'aime bien les trucs carrés,
j'ai repris légèrement le code pour une bonne compréhension.
sans rien changé.

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

Jean-Paul

 

[Si...]

Re : Astuce du jour: Tri Tableau Ascendant Descendant

salut

avec 2010 et sans doute autres et un tableau (avec titres) :

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

 

[MJ13]

Re : Astuce du jour: Tri Tableau Ascendant Descendant

Bonjour Jean-Paul, Si...

Merci JP pour le code qui est plus clair maintenant .

Merci Si... pour ce code ultra-condensé. Super .

Sinon avec ton code tu peux aussi écrire:

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

 

[MJ13]

Re : Astuce du jour: Range Dossier suivant extension des fichiers

Bonjour à tous

voici un petit fichier pour ranger un dossier en copiant les fichiers qui s'y trouvent dans des sous-dossiers suivant les extensions des fichiers .

Pour le tester, copier quelques fichiers avec différentes extensions vers un dossier, C:\Temp par exemple. Puis double-cliquer sur les cellules en orange pour lancer les macros. Notons que si vous double-cliquez en A1, vous devez ouvrir le dossier.

 

[MJ13]

Re : Astuce du jour: Range Dossier suivant extension des fichiers

Bonjour à tous

Voici la seconde version pour ranger un dossier .

Maintenant, vous pouvez en cliquant sur la case rouge: Lister, déplacer vers le dossier \A, supprimer les fichiers à la racine puis lister les nouveaux fichiers en 1 seule opération.

 

[MJ13]

Re : Astuce du jour: Résolution Ecran

Bonjour à tous

Voici un petit fichier pour vérifier que votre écran est bien configuré pour la résolution par rapport à sa taille.

Il vous faudra un double-décimètre et une image.

 

[david84]

Re : Astuce du jour: Résolution Ecran

Bonjour,
Au cas où cela peut servir : récupérer la résolution d'écran définie dans vos paramètres (panneau de configuration) :

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

A+

 

[JCGL]

Re : Astuce du jour: Résolution Ecran

Bonjour à tous,
Salut Michel,
Salut David,

David : sous XL 2013 32 et Win 8.1 64 :



A++ les amis
A+ à tous