Sélection de cellule multiples

Version imprimable

Bonjour,
Je cherche à sélectionner toutes les cellules des colonnes H:K en fonction de la valeur insrcite colonne A.

Voici le code que j'ai fait mais qui ne fonctionne pas.
Si quelqu'un peut m'aider?

Merci beaucoup de votre aide.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Sub RechercheSelect()
Dim R As Range
Dim C As Range
Dim var
 
Range("A:A").Select
var = 1249
 
If IsNumeric(var) Then var = CDbl(var)
For Each C In Selection
  If C = var Then
    If R Is Nothing Then
      Set R = C
    Else
      Set R = Application.Union(R, C)
    End If
  End If
Next C
If Not R Is Nothing Then
  R.Select
'Selection(, 8).Resize(, 4).Select (Ca ne marche pas)
Else
  MsgBox "Aucun bon d'achat N°" & var & " n'a été trouvée"
End If
End Sub

Sélection de cellule multiples

Bonjour,
Je cherche à sélectionner toutes les cellules des colonnes H:K en fonction de la valeur insrcite colonne A.

Voici le code que j'ai fait mais qui ne fonctionne pas.
Si quelqu'un peut m'aider?

Merci beaucoup de votre aide.
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 Sub RechercheSelect() Dim R As Range Dim C As Range Dim var Range("A:A").Select var = 1249 If IsNumeric(var) Then var = CDbl(var) For Each C In Selection If C = var Then If R Is Nothing Then Set R = C Else Set R = Application.Union(R, C) End If End If Next C If Not R Is Nothing Then R.Select 'Selection(, 8).Resize(, 4).Select (Ca ne marche pas) Else MsgBox "Aucun bon d'achat N°" & var & " n'a été trouvée" End If End Sub

24/08/2018, 14h42
halaster08

Bonjour,

Pourquoi ne pas simplement utiliser un filtre sur la colonne A ?
24/08/2018, 14h46
martinigi

Je doit ensuite copier coller les valeurs dans un autre tableau. Si je fait un filtre, ça me sélectionne les cellules filtrés aussi.
24/08/2018, 15h14
halaster08

Normalement le copier/coller ignore les cellules filtrées, puis-je voir ton code de copie/collage ?

Tu peux aussi je ter un œil à ce tuto https://philippetulliez.developpez.c...dvancedfilter/, tu peux filtrer et copier en même temps.

Bonjour,
En effet ça marche avec le filtre je n'avais pas fait attention, mais là ou j'ai un problème avec cette méthode c'est que je ne veux copier que les lignes comportant des données. Dans mon code ça me copie toute les lignes vides apres le filtres :
Code:

1 2 3 4 5 6 7 8 9 10 11 Sub Macro1() Sheets("Base de donnée").Select ActiveSheet.Range("$A$1:$O$500").AutoFilter Field:=1, Criteria1:="1249" Range("H28:K500").Copy Sheets("Bon de commande").Select Range("I17").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("J25").Select End Sub

Citation:

Envoyé par martinigi

Bonjour,

Une version une peu modifiée de votre code :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
 
Option Explicit
 
Public R As Range
 
Sub RechercheSelect(ByVal FeuilleBonAchat As Worksheet, TitreFeuille As Long, ByVal NumeroBonAchat As Variant)
Dim AireBonAchat As Range
Dim C As Range
Dim DerniereLigne As Long
 
    Application.ScreenUpdating = False
    With FeuilleBonAchat
         DerniereLigne = .Cells(.Rows.Count, 1).End(xlUp).Row
         Set AireBonAchat = .Range(.Cells(TitreFeuille + 1, 1), .Cells(DerniereLigne, 1))
         For Each C In AireBonAchat
             If C = NumeroBonAchat Then
                If R Is Nothing Then
                  Set R = Range(C.Offset(0, 7), C.Offset(0, 10))
                Else
                  Set R = Application.Union(R, Range(C.Offset(0, 7), C.Offset(0, 10)))
                End If
             End If
         Next C
         Set AireBonAchat = Nothing
    End With
    Application.ScreenUpdating = True
 
End Sub

Dans le module de Feuil1

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
 
Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
 
    If Target.Count > 1 Then Exit Sub
 
    If Not Intersect(Target, Range("CelluleBonAchat")) Is Nothing Then
 
       RechercheSelect ActiveSheet, 10, Target
 
       With Range("ResultatCelluleBonAchat")
            If Not R Is Nothing Then
               R.Select
               .Value = R.Address
            Else
              .Value = "Aucun bon d'achat N°" & Range("CelluleBonAchat") & " n'a été trouvé."
            End If
        End With
 
        Set R = Nothing
 
    End If
 
End Sub

Nb : Je me suis peut-être emmêlé les pinceaux entre bon d'achat et numéro de commande...

Pièce jointe 406401

Bonjour,

@Patrick bien vu moi j'étais sur ce poste et je n'avais pas vu l'autre :ccool:

Bon pour ne pas mettre à la poubelle ce que j'ai commencé (code à adapter bien sur …) :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Sub GetRange()
Dim Entete_Debut As Byte, Crit, Trouve&, F As Boolean, R As Range
 
Entete_Debut = 1 ' chiffre variable  pour retirer l'en-tête ou commencé à un ligne précise
Crit = Application.InputBox("Recherche :", "RECHERCHE BON ACHAT")
Application.ScreenUpdating = False
With ActiveSheet
If Not .AutoFilter Is Nothing Then F = True
    With .Cells(1).CurrentRegion
    Trouve = Application.CountIf(.Columns.Item(1), Crit)
        If Trouve > 0 And Crit > "" Then
            .AutoFilter Field:=1, Criteria1:=Crit
            Set R = .Offset(Entete_Debut, 7).Resize(.Rows.Count - Entete_Debut, 4).SpecialCells(xlCellTypeVisible)
            R.Copy:  Sheets("Bon de commande").Range("I" & Feuil2.Cells(Rows.Count, "I").End(xlUp)(2).Row).PasteSpecial xlPasteValues
        Else
            MsgBox "Aucun bon d'achat N°" & Crit & " n'a été trouvée"
        End If
    If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
    If Crit > "" And Trouve > 0 And F = False Then .AutoFilter
    End With
End With
Application.ScreenUpdating = True
Set R = Nothing
End Sub