Microsoft 365 CurrentRegion : sélection de cellules

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Bonjour à toutes et à tous,
Je vous souhaite une belle et chaude journée :)

Je n'arrive pas à adapter un code que Job75 m'a donné.
Le code était(pour appliquer une formule) :
VB:
Code origine Gérard
Sheets("Comptage_appels").Select
ActiveSheet.Unprotect Password:=""
    With [a1].CurrentRegion
    If .Rows.Count > 1 Then .Cells(4, 16).Resize(.Rows.Count - 1) = "=IF(OR(RC[-6]="""",RC[-5]=""""),"""",IF(VALUE(SUBSTITUTE(LEFT(RC[-6],8),""-"",""/"",1))=TODAY(),1,IF(MONTH(EOMONTH(VALUE(SUBSTITUTE(LEFT(RC[-6],8),""-"",""/"",1)),0))=MONTH(TODAY()),2,IF(MONTH(EOMONTH(VALUE(SUBSTITUTE(LEFT(RC[-6],8),""-"",""/"",1)),0))<MONTH(TODAY()),""3"",""""))))"
    .Columns(16) = .Columns(16).Value 'supprime les formules
    [P3] = "=SUM(RC[-4]:RC[-2])"
    End With
ActiveSheet.Protect Password:="", DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
et fonctionne très dans le fichier pour lequel il a été fait.

J'ai tenté de le modifier comme suit pour faire une sélection de cellules :
Code:
With [a6].CurrentRegion
    If .Rows.Count > 1 Then .Cells(1, 16).Resize(.Rows.Count).Select
    'If .Rows.Count > 1 Then .Cells(1, 16).Resize(.Rows.Count).Select
    '.Cells(4, 16).Resize(.Rows.Count - 1)
    End With
Mais ça ne fonctionne pas et je n'arrive pas à trouver comment faire.

J'ai besoin que seules les cellules en colonnes P avec "RdV Fait" contenu en colonne "J" soient sélectionnées.

Pourriez-vous m'aider ?
Je joins un fichier test et je continue à bidouiller ;)

Un grand merci encore une fois,
Amicalement,
lionel,
 

Pièces jointes

  • CurrentRegion.xlsm
    52.4 KB · Affichages: 13
Dernière édition:
Solution
Fichier (2) avec création des listes de validation :
VB:
Sub sélection()
    With ActiveSheet 'Feuil1 'CodeName
        If .FilterMode Then .ShowAllData 'si la feuille est filtrée
        .Columns(16).Validation.Delete 'RAZ
        With .Rows("6:" & .Range("j" & .Rows.Count).End(xlUp).Row)
            If .Row < 6 Then Exit Sub 'sécurité
            Application.ScreenUpdating = False
            .Rows.RowHeight = 55
            .Sort .Columns(10), xlAscending, Header:=xlNo 'tri
            Union(.Rows(0), .Rows).AutoFilter 10, "RDV Fait*" 'filtre automatique
            On Error Resume Next 'si aucune SpecialCell
            With Intersect(.SpecialCells(xlCellTypeVisible), .Columns(16))
                Application.Goto .Cells(1), True...

job75

XLDnaute Barbatruc
Bonjour Lionel, Marcel32, le forum,

Oui si l'on veut voir uniquement 'RDV Fait" il ne faut pas ôter le filtre.

Mais à mon avis c'est gênant : quand et comment l'ôterez-vous ?

Le fait de voir toutes les cellules ne me paraît pas gênant.

Ce qui est important c'est qu'il y ait des listes de validation en colonne P juste pour "RDV Fait".

On pourrait colorer les cellules concernées en colonne P.

A+
 

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Bonjour Gérard :)
Voici comment j'ai fait :
VB:
Sub sélection()
    With ActiveSheet 'Feuil1 'CodeName
        If .FilterMode Then .ShowAllData 'si la feuille est filtrée
        .Columns(16).Validation.Delete 'RAZ
        With .Rows("6:" & .Range("j" & .Rows.Count).End(xlUp).Row)
            If .Row < 6 Then Exit Sub 'sécurité
            Application.ScreenUpdating = False
            .Rows.RowHeight = 55
            .Sort .Columns(10), xlAscending, Header:=xlNo 'tri
            Union(.Rows(0), .Rows).AutoFilter 10, "RDV Fait" 'filtre automatique
            On Error Resume Next 'si aucune SpecialCell
            With Intersect(.SpecialCells(xlCellTypeVisible), .Columns(16))
                Application.Goto .Cells(1), True 'sélectionne et cadre la 1ère cellule visible en colonne P
                .Validation.Add xlValidateList, Formula1:="Validé,Annulé"
            End With
            ActiveWindow.ScrollColumn = 1
            '.AutoFilter 'ôte le filtre
        End With
        End With
    ActiveCell.Offset(0, -6).Select
    ActiveCell.FormulaR1C1 = "=""RdV Fait ""&RC[6]"
    ActiveCell.Copy
    Range(ActiveCell.Offset(1, 0), Cells(Rows.Count, "j").End(xlUp)).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.Offset(-1, 0).Select
End Sub
Sub Affiche()
'    'validation NON
    Selection.AutoFilter 'ôte le filtre
    Columns("J:J").Select
    Selection.Find(What:="RdV Fait", After:=ActiveCell, LookIn:=xlFormulas2, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
 
    Range(ActiveCell.Offset(0, 0), Cells(Rows.Count, "j").End(xlUp)).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    [p:p] = ""
    With [p:p].Validation
        .Delete
        .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
        :=xlBetween
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
    End With
    Application.CutCopyMode = False
'[a1].Select
End Sub
ça me permet d'affecter les "Validé" ou "Annulé" sans toucher aux "RdV Fait" traités précédemment.
Fichier joint,
ça fonctionne :)
Encore merci à toi :)
lionel,
 

Pièces jointes

  • CurrentRegion.xlsm
    60.1 KB · Affichages: 2
Dernière édition:

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Bonjour à toutes et à tous,
Je vous souhaite un beau WE :)

Je reviens sur le sujet car à l'utilisation j'aimerais apporter une amélioration.
Encore merci à Gérard pour son super code ;)

Dans 1 mois, on peut prendre jusqu'à 100 (voire plus) RdVs.
Quelques uns sont annulés et il est plus rapide et moins fastidieux de mentionner uniquement les "RdV Fait Annulé"

Pour cela, j'aimerais que le code mentionne automatiquement pour toutes les cellules sélectionnées "RdV Fait Validé"

Mais lol (évidemment :mad:), je n'arrive pas à coder correctement malgré mes tentatives :
Voici ce que je voudrais obtenir :
1638631961424.png

Auriez-vous le bon code ?
Je joins le fichier test et je continue mes recherches.
un grand merci :)
Amicalement,
lionel,
 

Pièces jointes

  • CurrentRegion.xlsm
    99.9 KB · Affichages: 4

Usine à gaz

XLDnaute Barbatruc
Supporter XLD

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
C'est le code du #post14 :
VB:
Sub Gérard()
With [A1].CurrentRegion
    If .Rows.Count > 1 Then .Cells(2, 9).Resize(.Rows.Count - 1) = "=IF(RC[-1]<>"""",LOOKUP(RC[-1],km),"""")"
    .Columns(9) = .Columns(9).Value 'supprime les formules
End With
End Sub

mais comme toujours, je l'ai modifié pour mon fichier de travail :)
 

laurent950

XLDnaute Accro
Bonsoir Lionel

Bon cette fois cela fonctionne très bien.

Pour les filtres et moteur de recherche il faut adapter

VB:
Sub sélectionbis()
Dim Wks1 As Worksheet
    Set Wks1 = Worksheets("Feuil1")
    If Wks1.FilterMode Then Wks1.ShowAllData 'si la feuille est filtrée
    Dim Rgn As Range
        Set Rgn = Wks1.Range(Wks1.Cells(6, 10), Wks1.Cells(Wks1.Cells(65536, 10).End(xlUp).Row, 10))
        'remise à Zéro de la plage
        Rgn.Offset(, 6).Clear
    Dim Sch() As Range
    ReDim Sch(0 To 0)
    Dim Plg As String
    Dim PlgSelect As Range
    With Rgn
        Set Sch(UBound(Sch)) = .Find(What:="RdV Fait", LookIn:=xlValues)
            If Not Sch(UBound(Sch)) Is Nothing Then
                Do
                    ReDim Preserve Sch(UBound(Sch) + 1)
                    Set Sch(UBound(Sch)) = .FindNext(Sch(UBound(Sch) - 1))
                Loop While Not Sch(UBound(Sch)).Row = Rgn.Rows.Count + Rgn.Row - 1
            End If
    End With
        For i = LBound(Sch) To UBound(Sch)
            If Sch(0).Value = Sch(i).Value Then
                Plg = Plg & Sch(i).Address & ", "
            End If
        Next i
        Plg = Left(Plg, Len(Plg) - 2)
        Set PlgSelect = Range(Plg)
            PlgSelect.Offset(, 6) = "RdV Fait"
        ' Filtre
            Rgn.AutoFilter Field:=1, Criteria1:=Sch(0).Value
            PlgSelect.Offset(, 6).Select
End Sub
 
Dernière édition:

Discussions similaires

Réponses
11
Affichages
396

Statistiques des forums

Discussions
311 725
Messages
2 081 941
Membres
101 847
dernier inscrit
Djigbenou