MACRO Extraire chaine de texte sur autre page

[Nougatine95]

Bonsoir toutes et tous,

Cela fait un bon moment que je ne suis pas venue vous solliciter.
Je viens ce soir vous soumettre un problème, qui ne sera pour vous qu'un simple exercice .

Dans un classeur: 2 feuilles
-La feuille 1 contient des données (nombreuses lignes et colonnes); feuille que je vais verrouiller.
-La feuille 2 est destinée à recevoir une extraction de feuille 1:
Une TextBox sur cette feuille 2 pour Extraction d'une chaîne de texte de colonne C).

Lorsque j'extrais en feuille 1 (sur place donc), le code est (code que vous m'aviez indiqué sur ce forum):
Private Sub TextBox1_Change()
If Me.TextBox1 <> "" Then
Range("C4").AutoFilter Field:=3, Criteria1:="=*" & Me.TextBox1 & "*"
Else
ActiveSheet.ShowAllData
End If
End Sub

Quel serait-il si j'extrais sur feuille 2?

Bien évidemment, j'ai cherché sur les antériorités du forum, mais je n'ai trouvé que des solutions où Extraction sur autre page mais TextBox se trouvant sur la page de données.

Merci pour votre aide.

 

[kjin]

Re : MACRO Extraire chaine de texte sur autre page

Bonsoir,
A tester

Private Sub TextBox1_Change()
If Me.TextBox1 <> "" Then
Application.ScreenUpdating = False
    With Sheets(1)
        .Unprotect
        .AutoFilterMode = False
        .Range("A1").AutoFilter Field:=3, Criteria1:="=*" & Me.TextBox1 & "*"
        .Protect
    End With
Application.ScreenUpdating = True
End If

End Sub

A+
kjin

 

[Nougatine95]

Re : MACRO Extraire chaine de texte sur autre page

Merci kjin,

Pour protection, je ferai manuellement, cela concerne uniquement la Feuille1, cela me permet de faire des modifs sur la BDD.

Pour la feuille 2, j'ai mis ton code mais pas de signe d'extraction. Puis avec modif en rouge, toujours rien.

Private Sub TextBox1_Change()
If Me.TextBox1 <> "" Then
Application.ScreenUpdating = False
    With Sheets(1)
        .Unprotect
        .AutoFilterMode = False
        .Range("[COLOR="Red"][SIZE="4"]C4[/SIZE][/COLOR]").AutoFilter Field:=3, Criteria1:="=*" & Me.TextBox1 & "*"
        .Protect
    End With
Application.ScreenUpdating = True
End If
End Sub

Keskispass... As-tu une petite idée?

 

[kjin]

Re : MACRO Extraire chaine de texte sur autre page

Bonsoir,
Sans fichier difficile de cibler
A+
kjin

 

[Nougatine95]

Re : MACRO Extraire chaine de texte sur autre page

Merci kjin,

Voici petit fichier,

En fait je souhaite extraire sur autre page car si je laisse extraction sur place, le fichier d'origine (=Feuil1) est régulièrement modifié par tierce personne (cause non connaissance Excel), un mot une lettre un chiffre remplace mots à l'origine dans une cellule...

J'ai tenté l'ajout de ces codes trouvés sur ce forum

Private Sub TextBox1_Change()
    ActiveSheet.Unprotect ("mdp") [COLOR="Lime"]'enlève la protection[/COLOR]
If Me.TextBox1 <> "" Then
    Range("C4").AutoFilter Field:=3, Criteria1:="=*" & Me.TextBox1 & "*"
Else
    ActiveSheet.ShowAllData
    ActiveSheet.Protect ("mdp") [COLOR="Lime"]'replace la protection[/COLOR]
End If
End Sub

mais lorsque je tape mot dans TextBox, cela dévérouille les cellules et autorise donc une modif pendant l'exécution de la macro, le problème demeure: Toujours cette possibilité de voir le fichier modifié

 

[kjin]

Re : MACRO Extraire chaine de texte sur autre page

Bonjour,
Voir PJ
A+
kjin

 

[Nougatine95]

Re : MACRO Extraire chaine de texte sur autre page

Merci kjin, pour ton devouement,

Malheureusement la macro ne m'extrait rien,

Private Sub TextBox1_Change()
Application.ScreenUpdating = False
If TextBox1 = "" Then
    Range("A5:E" & ActiveSheet.UsedRange.Rows.Count).Delete
Else
    Range("A4:E" & ActiveSheet.UsedRange.Rows.Count).Delete
    Range("I2") = "Nom"
    Range("I3") = TextBox1
    Sheets("Feuil1").Range("A4:E48").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("I2:I3"), CopyToRange:=Range("A4"), Unique:=False
    Range("I2:I3").Clear
End If
Application.ScreenUpdating = True

End Sub

et étant inexperte dans ce domaine, je serais incapable de juger d'où vient le problème.

 

[klin89]

Re : MACRO Extraire chaine de texte sur autre page

Bonjour à tous,
Bonjour Nougatine95, kjin

Pour t'aider, j'ai trouvé dans le fil ci-dessous, un exemple de ce que tu recherches.

https://www.excel-downloads.com/threads/sumproduct.106998/

Il suffit de saisir une chaine de caractères dans une textbox (formulaire "Rechercher").

Sont extraites toutes les lignes concernées par le "mot choisi".

Dans le fichier concerné, j'ai épuré le code affecté au CommandButton1 pour ne garder que l'essentiel. (Voir plus bas)
Tu pourrais ainsi t'en inspirer.

Précision : la recherche s'effecue en colonne C des feuilles commençant par 'Encais".

....
If Left(.Name, 6) = "Encais" Then
....

Le code épuré sur lequel tu pourrais t'inspirer.

Private Sub CommandButton1_Click()
  Dim VSearch As String
  ShtR.[H1].Value = TextBox1.Value
  If TextBox1.Value = "" Then Exit Sub
  Application.ScreenUpdating = False
  x = 1
  VSearch = Me.TextBox1.Value
  For Each Ws In ThisWorkbook.Worksheets
    With Ws
      DerLiS = .Range("C65536").End(xlUp).Row
      If Left(.Name, 6) = "Encais" Then
        i = Len(TextBox1.Value)
        For Each Cellule In .Range("C2:C" & DerLiS)
          If InStr(1, Cellule, VSearch, vbTextCompare) > 0 Then
              trouve = True
                DerLiR = ShtR.Range("A65536").End(xlUp).Row + 1
                For col = 1 To 7
                  ShtR.Cells(DerLiR, col).Value = Ws.Cells(Cellule.Row, col).Value
                Next
                x = x + 1
            End If
        Next Cellule
      End If
     End With
  Next Ws
  If trouve = False Then MsgBox "Pas de trace !"
  Unload Me
  Application.ScreenUpdating = True
End Sub

Je te laisse poursuivre, à toi de l'adapter à ton cas.

Amicalement Klin89

Ps : la recherche ne doit s'effectuer que sur une seule feuille, il y a peut-être plus simple à réaliser contrairement à ce que je te présente, mais le résultat correspond t-il bien à ta demande ?

 

[kjin]

Re : MACRO Extraire chaine de texte sur autre page

Re, salut klin,
Autant pour moi, j'avais zapper que tu cherchais les mots se situant n'importe où dans la chaîne
Donc remplace

Range("I3") = TextBox1

par

Range("I3") = "*" & TextBox1 & "*"

Sinon je ne pige pas ce que tu veux
A+
kjin

 

[Nougatine95]

Re : MACRO Extraire chaine de texte sur autre page

Merci klin89,

J'ai tenté petites modifs pour adaptation perso, mais je suis loin, bien loin, d'avoir le niveau du forum en Macro.
Je stagne donc.

Recherche sur une seule feuille en effet.

 

[Nougatine95]

Re : MACRO Extraire chaine de texte sur autre page

Oups nos messages ce sont croisés, je regarde ta dernière proposition.

 

[kjin]

Re : MACRO Extraire chaine de texte sur autre page

Re,

J'ai tenté petites modifs pour adaptation perso...

Quand tu dis que "ça ne m'extrait rien", s'agit-il de mon fichier où de ta réadaptation !?
A+
kjin

 

[Nougatine95]

Re : MACRO Extraire chaine de texte sur autre page

Klin89,
Il s'agit des 2

 

[kjin]

Re : MACRO Extraire chaine de texte sur autre page

Re,
Non moi c'est kjin !
Si c'est bien à moi que tu t'adresses
Si c'est le cas, avec mon fichier lorsque tu entres "a" dans la textbox n'y a t-il rien qui s'affiche !
Si oui, c'est que ça fonctionne mais que ça n'est peut-être pas ce que tu attends et là faut m'expliquer mieux et en gaulois de préférence
Si non, alors là je mange mon chapeau
A+
kjin

 

[Nougatine95]

Re : MACRO Extraire chaine de texte sur autre page

Voici le résultat attendu, merci Kjin, merci Klin89,
J'ai modifié ton code Kjin, comme tu viens de me le suggérer.
Ce code fonctionne à merveille:

Private Sub TextBox1_Change()
Application.ScreenUpdating = False
If TextBox1 = "" Then
    Range("A5:E" & ActiveSheet.UsedRange.Rows.Count).Delete
Else
    Range("A4:E" & ActiveSheet.UsedRange.Rows.Count).Delete
    Range("I2") = "Nom"
    Range("I3") = "*" & TextBox1 & "*"
    Sheets("Feuil1").Range("A4:E48").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("I2:I3"), CopyToRange:=Range("A4"), Unique:=False
    Range("I2:I3").Clear
End If
Application.ScreenUpdating = True

End Sub

Je joins le fichier qui pourra peut-être être utile à d'autres.

Merci Beaucoup à tous les deux, pour votre dévouement et votre patience.