Recherche code dans cellules

[batistuta]

bonjour,
sur le fichier ci joint ,je souhaite créer une macro qui me lance une recheche qui sera faite de la manière suivante:
1/sélectionner la colonne ou va s'effectuer la recherche: référence ( cellule E14 de la feuille2)
2/rechercher le code affiché dans la cellule I14 de la feuille2 (exemple:"1a")
3/afficher les lignes qui contiennent ce code sur une autre feuille

C'est très important.
Merci

 

[job75]

Re : Recherche code dans cellules

Bonjour batistuta, bienvenue sur XLD,

Fichier joint avec cette macro dans le code de Feuil2 :

Private Sub CommandButton1_Click()
Dim F1 As Worksheet, F3 As Worksheet, col, cel As Range, plage As Range
Set F1 = Sheets("Feuil1") 'feuille de données
Set F3 = Sheets("Feuil3") 'feuille de restitution

col = Application.Match([E14], F1.Rows(1), 0)
If IsError(col) Then Exit Sub
For Each cel In F1.Range(F1.Cells(2, col), F1.Cells(65536, col).End(xlUp))
 If InStr(cel, [I14]) Then _
   Set plage = Union(cel.MergeArea, IIf(plage Is Nothing, cel.MergeArea, plage))
Next

F1.Cells.Copy F3.Cells 'pour copier les formats des colonnes, on peut supprimer ensuite
F3.Rows("2:65536").Clear
If Not plage Is Nothing Then plage.EntireRow.Copy F3.Rows(2)
F3.Activate 'facultatif

End Sub

A+

 

[job75]

Re : Recherche code dans cellules

Re,

La macro précédente fonctionne bien si l'on entre le mot "plage" en E14.

Si l'on entre le mot "contact", le copier-coller ne prend pas en compte les cellules fusionnées (ah les cellules fusionnées, VBA n'aime pas ça...).

Voici une solution, un peu trapue à comprendre, qui prend en compte tous les cas de figure :

Private Sub CommandButton1_Click()
Dim F1 As Worksheet, F3 As Worksheet, col, n&, cel As Range, lig As Byte, cel1 As Range
Set F1 = Sheets("Feuil1") 'feuille de données
Set F3 = Sheets("Feuil3") 'feuille de restitution

F1.Cells.Copy F3.Cells 'pour copier les formats des colonnes, on peut supprimer ensuite
F3.Rows("2:65536").Clear
col = Application.Match([E14], F1.Rows(1), 0)
If IsError(col) Then Exit Sub
n = 2

For Each cel In F1.Range(F1.Cells(2, col), F1.Cells(65536, col).End(xlUp))
  [COLOR="Red"]If LCase(cel) Like "*" & LCase([I14]) & "*" Then[/COLOR]
    F1.Cells(cel.Row, 1).MergeArea.EntireRow.Copy F3.Rows(n)
    If Not cel.MergeCells Then
      lig = Application.Match(cel, Intersect(F3.Cells(n, 1).MergeArea.EntireRow, F3.Columns(col)), 0)
      F3.Cells(n, 1).MergeArea.EntireRow.ClearContents
      cel.EntireRow.Copy F3.Rows(n + lig - 1)
      For Each cel1 In Intersect(F3.Rows(n + lig - 1), F3.UsedRange)
        If cel1.MergeCells Then cel1.MergeArea(1) = F1.Cells(cel.Row, cel1.Column).MergeArea(1)
      Next
    End If
    n = n + F3.Cells(n, 1).MergeArea.Count
  End If
Next

F3.Activate 'facultatif

End Sub

Noter (code en rouge) l'utilisation de Like, ce qui permet dans la recherche d'utiliser les caractères génériques * ou ?.

A+

 

[job75]

Re : Recherche code dans cellules

Bonjour batistuta, le forum,

Peut-être cette solution est-elle préférable, elle met en forme les copies des cellules fusionnées :

Private Sub CommandButton1_Click()
Dim F1 As Worksheet, F3 As Worksheet, col, n&, cel As Range, cel1 As Range
Set F1 = Sheets("Feuil1") 'feuille de données
Set F3 = Sheets("Feuil3") 'feuille de restitution

F1.Cells.Copy F3.Cells 'pour copier les formats des colonnes, on peut supprimer ensuite
F3.Rows("2:65536").Clear
col = Application.Match([E14], F1.Rows(1), 0)
If IsError(col) Or [I14] = "" Then Exit Sub
n = 2

For Each cel In F1.Range(F1.Cells(2, col), F1.Cells(65536, col).End(xlUp))
  If LCase(cel) Like "*" & LCase([I14]) & "*" Then
    cel.MergeArea.EntireRow.Copy F3.Rows(n)
    If Not cel.MergeCells Then
      For Each cel1 In Intersect(F3.Rows(n), F3.UsedRange)
        With cel1
          If F1.Cells(cel.Row, .Column).MergeCells Then
            .Value = F1.Cells(cel.Row, .Column).MergeArea(1)
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .WrapText = True 'retour à la ligne
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
          End If
        End With
      Next
    End If
    n = n + cel.MergeArea.Count
  End If
Next

F3.Activate 'facultatif

End Sub

A+