Discussion :

[vefa12]

Bonjour,

Je travaille sur un projet en utilisant VBA sous EXCEL, et j'ai un petit soucis !!

J'ai un fichier avec plus de 1000 lignes et plusieurs lignes correspond a une entrée (ex /COLLC1111 ou /COLLC1212 ou bien /JEGUC0017).

Lorsque j'appuie sur le bouton recherche, et que je tape l'entrée voulu (/COLLC1111 par ex), je dois avoir toutes les lignes de B à I enregistrer sur la feuille 2.

J'ai commencé à exécuter un code mais cela ne fonctionne, pouvez vous m'aider et m'orienter sur ma démarche svp.

En vous remerciant!

[gFZT82]

Bonjour,

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Private Sub CommandButton1_Click()
Dim Cel As Range
Dim Ligne As Long
    Application.ScreenUpdating = False
    Ligne = 2
    With Sheets("Feuil2")
        .Range("A2:I" & .Range("A2").End(xlDown).Row).ClearContents
        For Each Cel In Sheets("donnees").Range("A2:A" & Sheets("donnees").Range("A2").End(xlDown).Row)
            If Cel.Value = Me.TextBox1.Value Then
                Cel.Offset(0, 1).Resize(1, 8).Copy .Range("A" & Ligne)
                Ligne = Ligne + 1
            End If
        Next Cel
    End With
    Unload Me
End Sub

Cordialement.

[vefa12]

bonjour,
ok je vous remercie
cdt

[Invité]

Variante:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Option Explicit
 
Private Sub CommandButton1_Click()
 
  Dim strValeur As String
 
  strValeur = Me.TextBox1.Text
  Worksheets("Feuil2").Cells.Clear
 
  With ActiveSheet
      .Range("A1").AutoFilter Field:=1, Criteria1:=strValeur
      .UsedRange.SpecialCells(xlCellTypeVisible).Copy Worksheets("Feuil2").[A1]
      Worksheets("Feuil2").Columns(1).Delete
      .AutoFilterMode = False
  End With
 
  Unload Me
 
End Sub

[vefa12]

très bien merci beaucoup

[SMBeccaria]

Bonjour,

Je suis en retard mais puisqu'elle est codée, voici une variante v2.0 avec un dictionary.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
29
30
31
32
33
34
35
 
Sub TEST()
    Dim myCol1 As String, mystring As String
    Dim myDico As Object
    Dim mysheet As Worksheet, myOPsheet As Worksheet
    Dim myrange As Range
 
    myCol1 = InputBox("Valeur recherchée")
    Set mysheet = ThisWorkbook.Worksheets(1)
 
    If Not myCol1 = "" Then
        If mysheet.Cells.Find(myCol1) <> "" Then
            Set myDico = CreateObject("Scripting.dictionary")
            Set myrange = mysheet.Range("A1")
            Do Until myrange = ""
                If myrange.Offset(, 1) = myCol1 Then
                    For i = 0 To 8
                        mystring = mystring & "," & myrange.Offset(, i)
                    Next
                    myDico.Add myrange.Row, Mid(mystring, 2, Len(mystring))
                    mystring = ""
                End If
                Set myrange = myrange.Offset(1)
            Loop
            If myDico.Count > 0 Then
                With ThisWorkbook.Worksheets(2)
                .Activate
                    .Cells.ClearContents
                    .Range("A1").Resize(myDico.Count).Value = Application.Transpose(myDico.Items)
                    .Range("A1").Resize(myDico.Count).TextToColumns Comma:=True
                End With
            End If
        End If
    End If   
End Sub

[Marc-L]

Moi aussi j'étais en retard et j'ai enlevé mon post quasi équivalent à celui de Vincent …

Franchement dans un cas comme celui là, la copie de données filtrées est rapide et simple tout en évitant l'usine à gaz ‼

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
Sub Demo()
    Feuil2.Cells.ClearContents
    Feuil1.[A1].AutoFilter 1, "/COLLC1111"
    Feuil1.Columns("B:I").SpecialCells(xlCellTypeVisible).Copy Feuil2.[B1]
    Feuil1.[A1].AutoFilter
End Sub