Fonction VBA testant texte dans une cellule

Bonjour à tous,

Je suis débutant en language VBA et j'ai un petit problème pour réaliser une fonction qui teste le contenu d'une cellule. Si le contenu contient teste alors elle réalise certaines opérations comme copier le contenu de la cellule d'à coté pour le copier sur un ppt.

Sub avertissement(texte As String)
    k = 4 ' Numéro de la slide ou copier le contenu de la cellule
         Set x1Sheet = Sheets("Feuil1")

      Derlig = Split(Worksheets("Feuil1").UsedRange.Address, "$")(4) 'Détermine la dernière ligne renseignée de la feuille de calculs
      NoCol = 1 'Fixe le N° de la colonne à lire

n = 1 'emplacement sur le slide

For i = 3 To Derlig 'Pour chaque ligne
    If Cells(i, 1).Value Like "& texte &" Then

        If n = 1 Then
            Set shpTexte = PptDoc.Slides(k).Shapes.AddTextbox(msoTextOrientationHorizontal, 50, 110, 600, 150)
              With shpTexte.TextFrame.TextRange
                .Font.Bold = msoTrue
                .Font.Size = 14
                .Font.Color = black
                .Text = Cells(i, 2).Value
                End With
                n = n + 1

        ElseIf n = 2 Then
            Set shpTexte = PptDoc.Slides(k).Shapes.AddTextbox(msoTextOrientationHorizontal, 50, 270, 600, 150)
              With shpTexte.TextFrame.TextRange
                .Font.Bold = msoTrue
                .Font.Size = 14
                .Font.Color = black
                .Text = Cells(i, 2).Value
                End With
                n = n + 1

        ElseIf n = 3 Then
            Set shpTexte = PptDoc.Slides(k).Shapes.AddTextbox(msoTextOrientationHorizontal, 50, 430, 600, 150)
              With shpTexte.TextFrame.TextRange
                .Font.Bold = msoTrue
                .Font.Size = 14
                .Font.Color = black
                .Text = Cells(i, 2).Value
                End With
            n = 1
            k = k + 1 ' Refaire la mêmee opération pour les cellules suivantes sur le slide suivant
        End If

i = i + 1
Next

    End If
End Sub

Sub ModifierPresentationExistante()
Dim PptApp As PowerPoint.Application
Dim PptDoc As PowerPoint.Presentation
Dim plage As Range, cel As Range, Derlig As Long
Set PptApp = CreateObject("Powerpoint.Application")
PptApp.Visible = True
Set PptDoc = PptApp.Presentations.Open("C:\Users\XY\Desktop\ve.pptx")

With PptDoc

     Set xlSheet = Sheets("Feuil1")

     avertissement ("Automobile") ' Appel de la fonction

End With
End Sub

Je suis vraiment débutant, si je peux expliquer un peu mieux mon problème dites le moi . En vous remerciant d'avance

Bonjour, est-ce que je peux simplifier le problème ou faire quoique ce soit pour avoir une petite aide?

Je suis toujours coincé pour cette fonction qui sert à rechercher un mot, exemple "automobile" dans une colonne Excel.

Merci d'avance

Bonjour,

essaie en modifiant cette instruction

If Cells(i, 1).Value Like "& texte &" Then

comme ceci

If Cells(i, 1).Value Like "* " & texte & " *" Then

Bonjour, merci pour votre réponse.

Celle- ci ne fonctionne toujours pas, j'ai l'erreur suivante sur la première ligne If :

Erreur définie par l'application ou par l'objet.

Function avertissement(texte As String)

If Cells(i, 1).Value Like "* " & texte & " *" Then

If n = 1 Then

Set shpTexte = PptDoc.Slides(k).Shapes.AddTextbox(msoTextOrientationHorizontal, 50, 110, 600, 150)

With shpTexte.TextFrame.TextRange

.Font.Bold = msoTrue

.Font.Size = 14

.Font.Color = black

.Text = Cells(i, 2).Value

End With

n = n + 1

ElseIf n = 2 Then

Set shpTexte = PptDoc.Slides(k).Shapes.AddTextbox(msoTextOrientationHorizontal, 50, 270, 600, 150)

With shpTexte.TextFrame.TextRange

.Font.Bold = msoTrue

.Font.Size = 14

.Font.Color = black

.Text = Cells(i, 2).Value

End With

n = 1

k = k + 1

End If

End If

i = i + 1

End Function

Bonjour,

la correction telle que tu l'as apportée, i a la valeur 0. ma correction s'appliquait au code que tu as fourni initialement et corrigeait uniquement le problème du test (l'objet de ta demande). Je n'ai pas vérifié la logique de ton code

Sub avertissement(texte As String)
    k = 4 ' Numéro de la slide ou copier le contenu de la cellule
        Set x1Sheet = Sheets("Feuil1")

      Derlig = Split(Worksheets("Feuil1").UsedRange.Address, "$")(4) 'Détermine la dernière ligne renseignée de la feuille de calculs
     NoCol = 1 'Fixe le N° de la colonne à lire

n = 1 'emplacement sur le slide

For i = 3 To Derlig 'Pour chaque ligne
   If Cells(i, 1).Value Like "*" & texte & "*" Then 'ligne modifiée dans ton code

        If n = 1 Then
            Set shpTexte = PptDoc.Slides(k).Shapes.AddTextbox(msoTextOrientationHorizontal, 50, 110, 600, 150)
              With shpTexte.TextFrame.TextRange
                .Font.Bold = msoTrue
                .Font.Size = 14
                .Font.Color = black
                .Text = Cells(i, 2).Value
                End With
                n = n + 1

        ElseIf n = 2 Then
            Set shpTexte = PptDoc.Slides(k).Shapes.AddTextbox(msoTextOrientationHorizontal, 50, 270, 600, 150)
              With shpTexte.TextFrame.TextRange
                .Font.Bold = msoTrue
                .Font.Size = 14
                .Font.Color = black
                .Text = Cells(i, 2).Value
                End With
                n = n + 1

        ElseIf n = 3 Then
            Set shpTexte = PptDoc.Slides(k).Shapes.AddTextbox(msoTextOrientationHorizontal, 50, 430, 600, 150)
              With shpTexte.TextFrame.TextRange
                .Font.Bold = msoTrue
                .Font.Size = 14
                .Font.Color = black
                .Text = Cells(i, 2).Value
                End With
            n = 1
            k = k + 1 ' Refaire la mêmee opération pour les cellules suivantes sur le slide suivant
       End If

i = i + 1
Next

    End If
End Sub

Sub ModifierPresentationExistante()
Dim PptApp As PowerPoint.Application
Dim PptDoc As PowerPoint.Presentation
Dim plage As Range, cel As Range, Derlig As Long
Set PptApp = CreateObject("Powerpoint.Application")
PptApp.Visible = True
Set PptDoc = PptApp.Presentations.Open("C:\Users\XY\Desktop\ve.pptx")

With PptDoc

     Set xlSheet = Sheets("Feuil1")

     avertissement ("Automobile") ' Appel de la fonction

End With
End Sub

Super merci !