recherche text entre 2 guilement

[PETIT YANNICK]

Bonjour

Dans mon cas ,je cherche a récupérer une valeur qui change dans un chemin d'accès.
Pour mon cas le texte source - ventilateur et co2
c'est une base de donnée, il faudrait que j'arrive a faire une formule complete qui prenne en compte ces données.
Le valeur recherchée est toujours entre le dernier et l'avant dernier \

C:\GRAVOTECH\BIBLIO\Eléments du commerce\Composants laser\Source\CO2\DET51314.SLDDRW
C:\GRAVOTECH\BIBLIO\Eléments du commerce\Composants laser\Source\DET51313.SLDDRW
C:\GRAVOTECH\BIBLIO\Eléments du commerce\Ventilateur\DET50491.SLDDRW

merci d'avance pour votre aide

Yannick

 

[job75]

Bonjour PETIT YANNICK,

Exécutez cette macro dans le fichier joint :

Sub Recherche()
Dim tablo, i&, x$, j%, k%
With Feuil1.[A1].CurrentRegion.Resize(, 2)
    tablo = .Value
    For i = 2 To UBound(tablo)
        x = tablo(i, 1)
        If x Like "*\*\*" Then
            j = InStrRev(x, "\")
            k = InStrRev(Left(x, j - 1), "\")
            tablo(i, 2) = Mid(x, k + 1, j - k - 1)
        Else
            tablo(i, 2) = ""
        End If
    Next
    .Columns(2) = Application.Index(tablo, , 2)
End With
End Sub

A+

 

[vgendron]

Hello
avec une fonction personnalisée..?

Public Function FExtraire(source As String)
tablo = Split(source, "\")
Taille = UBound(tablo)
FExtraire = tablo(Taille - 1)
End Function

hello @job75

 

[Chris401]

Bonsoir
@vgendron : fonction géniale !
Est-il possible d'ajouter un argument pour le choix du 1 ?

FExtraire = tablo(Taille - 1)

Style :

=Fextraire(A1;1)
=Fextraire(A1;3)

Merci de ton retour.

 

[youky(BJ)]

Bonsoir tous,
Pour répondre à Chris401,

Public Function FExtraire(source As String, n As Long)
tablo = Split(source, "\")
FExtraire = tablo(n)
End Function

Bruno

 

[PETIT YANNICK]

Je cherche également a supprimer toutes les ligne contenant le texte sldrw
quelqu'un aurait une idée

ligne en rouge dans le fichier

 

[vgendron]

et cette version pour permettre de choisir le numéro.. ou ne rien mettre pour avoir l'avant dernier par défaut

Public Function FExtraire(source As String, Optional n As Long = -1)
tablo = Split(source, "\")
taille = UBound(tablo)
If n = -1 Then
    FExtraire = tablo(taille - 1)
Else
    FExtraire = tablo(n)
End If
End Function

 

[vgendron]

et pour la suppression..

Sub purger()
Dim tablo() As Variant
Dim tabloFinal() As Variant
TexteCherché = Application.InputBox("tapez le texte que contiennent les lignes à supprimer")
TailleF = 0
With Sheets("Feuil1")
   
    tablo = .UsedRange.Value
    For i = LBound(tablo, 1) To UBound(tablo, 1)
        If tablo(i, 1) Like "*" & TexteCherché & "*" Then
            For j = LBound(tablo, 2) To UBound(tablo, 2)
                tablo(i, j) = ""
            Next j
        Else
            TailleF = TailleF + 1
        End If
    Next i
    .UsedRange.Offset(1, 0).Clear
    ReDim tabloFinal(1 To TailleF, 1 To UBound(tablo, 2))
   
    k = 1
    For i = LBound(tablo, 1) To UBound(tablo, 1)
        If tablo(i, 1) <> "" Then
            For j = LBound(tablo, 2) To UBound(tablo, 2)
                tabloFinal(k, j) = tablo(i, j)
            Next j
            k = k + 1
        End If
    Next i
   
   
    .Range("A2").Resize(UBound(tabloFinal, 1), UBound(tabloFinal, 2)) = tabloFinal
End With
End Sub

 

[Chris401]

Re

Merci beaucoup et bonne soirée

 

[laurent950]

Bonsoir
la boucle est écrite avec des valeurs absolu pour ligne 9 (fin) à 2 (début)
la boucle commence de la dernière ligne à la première ligne

Sub test()
For i = 9 To 2 Step -1
    If LCase(Split(Cells(i, 1), ".")(1)) = LCase("slddrw") Then
        ' Je cherche également a supprimer toutes les ligne contenant le texte sldrw // SLDDRW dans votre fichier
        Cells(i, 1).EntireRow.Delete
    Else
        ' Colonne B (La valeur recherchée est toujours entre le dernier et l'avant dernier \)
        Cells(i, 2) = Split(Cells(i, 1), "\")(UBound(Split(Cells(i, 1), "\")) - 1)
    End If
Next i
End Sub

cdt

 

[PETIT YANNICK]

vgendron
Merci pour la macro, par contre la macro marque erreur de debogage
voir fichier ci joint

 

[vgendron]

celle que j'ai fournie ne mettait pas d'erreur
==> si tu ajoutes option explicit. il faut déclarer toutes les variables (le message d'erreur le laisse entendre...)
ensuite.. la recherche du mot..
moi, je mettais une boite pour saisir le mot
toi, tu as mis le mot en "dur"... la syntaxe n'est donc plus bonne..

Option Explicit

Sub purger()
Dim tablo() As Variant
Dim tabloFinal() As Variant
Dim TailleF As Long
Dim i, j, k As Long

TailleF = 0
With Sheets("Feuil1")
  
     tablo = .UsedRange.Value
     For i = LBound(tablo, 1) To UBound(tablo, 1)
         If tablo(i, 1) Like "*" & "slddrw" & "*" Then
             For j = LBound(tablo, 2) To UBound(tablo, 2)
                 tablo(i, j) = ""
             Next j
         Else
             TailleF = TailleF + 1
         End If
     Next i
     .UsedRange.Offset(1, 0).Clear
     ReDim tabloFinal(1 To TailleF, 1 To UBound(tablo, 2))
  
     k = 1
     For i = LBound(tablo, 1) To UBound(tablo, 1)
         If tablo(i, 1) <> "" Then
             For j = LBound(tablo, 2) To UBound(tablo, 2)
                 tabloFinal(k, j) = tablo(i, j)
             Next j
             k = k + 1
         End If
     Next i
  
  
     .Range("A2").Resize(UBound(tabloFinal, 1), UBound(tabloFinal, 2)) = tabloFinal
End With
End Sub

 

[PETIT YANNICK]

Merci à tous pour vos retours
yannick