XL 2013 Rechercher et modifier la valeur d'une cellule dans tout un classeur

[EXCJPH]

Bonjour aux experts ! J'ai vraiment besoin de votre aide car suis débutant et c'est un petit mot

J'ai un classeur MODIF.xlsm sans un dossier. Dans ce même dossier se trouvent plusieurs autres classeurs en xls.

Depuis MODIF.xlsm (macro Lance) je souhaite ouvrir successivement (Un par un) chaque classeur.xls pour chercher dans toutes les feuilles

de ces classeurs dont je ne connais pas le nom les cellules qui contiennent la valeur "Ring" et faire le traitement qui suit:

Effacer le contenu des cellules concernées mais aussi le contenu de la cellule juste en dessous, puis enregistrer et passer au classeur suivant.

Voila, si seulement vous pouviez m'aider. Merci déjà à vous

J'ai commencé avec l'ouverture des classeurs un par un mais je bloque sur le traitement.

Sub Lance()
chemin = ThisWorkbook.Path
PC = Dir(chemin & "\*.xls") ' premier fichier

Do While (PC <> "" And PC <> "MODIF.xlsm")

Workbooks.Open Filename:=chemin & "\" & PC

VOTRE PROCEDURE D'AIDE

PC = Dir
Loop
End Sub

 

[job75]

Bonjour EXCJPH, Waiky,

Par contre Je n'arrive pas à compter le nombre d’occurrence trouvé

Il suffit d'ajouter ce compteur, fichier (2) :

n = n + R.Count 'compteur

A+

 

[job75]

Si vous voulez que le nombre d'occurrences soit restitué dans la feuille utilisez ce fichier (3) :

Option Compare Text 'la casse est ignorée

Sub Lance()
Dim chemin$, PC$, source As Range, w As Worksheet, R As Range, n&, nn&, c As Range
chemin = ThisWorkbook.Path
PC = Dir(chemin & "\*.xls*") ' premier fichier
Set source = [A2:A6] 'valeurs à rechercher
Application.ScreenUpdating = False
On Error Resume Next 'si aucune SpecialCell
source.Offset(, 1) = "" 'RAZ
While PC <> ""
    If PC <> ThisWorkbook.Name Then
        With Workbooks.Open(chemin & "\" & PC)
            For Each w In .Worksheets
                Set R = Nothing: n = 0: nn = 0
                For Each c In source
                    If CStr(c) <> "" Then
                        w.Cells.Replace c, "#N/A", xlWhole
                        Set R = w.Cells.SpecialCells(xlCellTypeConstants, 16)
                        n = R.Count - nn
                        nn = nn + n
                        If n Then c(1, 2) = c(1, 2) + n 'comptage
                    End If
                Next c
                R = ""
                For Each R In R.Offset(1)
                    If R Like "*--*" Then R = ""
            Next R, w
            .Close True 'enregistre et ferme le fichier
        End With
    End If
    PC = Dir
Wend
End Sub

 

[EXCJPH]

Bonjour job75 et le forum
Vous degainez plus vite que votre ombre et moi je tarde à vous répondre. Faute à panne de signal internet dans mon quartier.
Désolé. Tout est revenu dans l'ordre maintenant et je découvre votre proposition.
Merci à vous. C'est parfait. L'algorithme est astucieux et fiable. Très impressionné par votre compétence ! Encore merci. Je vais tenter maintenant de récupérer dans une autre feuille du classeur maître le nom des feuilles des fichiers Xls ou les occurrences de chaque strings de la plage apparaissent au moins une fois. Je vais bosser dessus mais si le sujet vous plaît...
Vous n'imaginez pas l'aide que vous avez apporté ! Bien à vous

 

[job75]

Bonsoir EXCJPH, le forum,

Je vais tenter maintenant de récupérer dans une autre feuille du classeur maître le nom des feuilles des fichiers Xls ou les occurrences de chaque strings de la plage apparaissent au moins une fois.

Pourquoi une autre feuille ? Une seule feuille suffit, voyez ce fichier (4) :

Option Compare Text 'la casse est ignorée

Sub Lance()
Dim chemin$, PC$, source As Range, col%, w As Worksheet, R As Range, n&, nn&, c As Range
chemin = ThisWorkbook.Path
PC = Dir(chemin & "\*.xls") ' premier fichier
Set source = [A2:A6] 'valeurs à rechercher
Application.ScreenUpdating = False
On Error Resume Next 'si aucune SpecialCell
source.Columns(3).EntireColumn.Resize(, Columns.Count - 2).Delete 'RAZ
source.Columns(2) = ""
col = 2
While PC <> ""
    If PC <> ThisWorkbook.Name Then
        With Workbooks.Open(chemin & "\" & PC)
            For Each w In .Worksheets
                col = col + 1
                source(0, col) = .Name & "!" & w.Name
                Set R = Nothing: n = 0: nn = 0
                For Each c In source
                    If CStr(c) <> "" Then
                        w.Cells.Replace c, "#N/A", xlWhole
                        Set R = w.Cells.SpecialCells(xlCellTypeConstants, 16)
                        n = R.Count - nn
                        nn = nn + n
                        If n Then
                            c(1, 2) = c(1, 2) + n 'comptage
                            c(1, col) = n
                        End If
                    End If
                Next c
                If Application.Sum(source.Columns(col)) = 0 Then source(0, col) = "": col = col - 1 'annulation
                R = ""
                For Each R In R.Offset(1)
                    If R Like "*--*" Then R = ""
            Next R, w
            .Close True 'enregistre et ferme le fichier
        End With
    End If
    PC = Dir
Wend
source(0, 3).Resize(, Columns.Count - 2).Columns.AutoFit 'ajustement largeurs
End Sub

A+

 

[job75]

Juste pour pinailler ce fichier (5) est un tout petit peu mieux :

Option Compare Text 'la casse est ignorée

Sub Lance()
Dim chemin$, PC$, source As Range, col%, w As Worksheet, R As Range, n&, nn&, c As Range
chemin = ThisWorkbook.Path
PC = Dir(chemin & "\*.xls") ' premier fichier
Set source = [A2:A6] 'valeurs à rechercher
Application.ScreenUpdating = False
On Error Resume Next 'si aucune SpecialCell
source.Columns(3).EntireColumn.Resize(, Columns.Count - 2).Delete 'RAZ
source.Columns(2) = ""
col = 2
While PC <> ""
    If PC <> ThisWorkbook.Name Then
        With Workbooks.Open(chemin & "\" & PC)
            For Each w In .Worksheets
                col = col + 1
                Set R = Nothing: n = 0: nn = 0
                For Each c In source
                    If CStr(c) <> "" Then
                        w.Cells.Replace c, "#N/A", xlWhole
                        Set R = w.Cells.SpecialCells(xlCellTypeConstants, 16)
                        n = R.Count - nn
                        nn = nn + n
                        If n Then
                            c(1, 2) = c(1, 2) + n 'comptage
                            c(1, col) = n
                        End If
                    End If
                Next c
                If Application.Sum(source.Columns(col)) Then source(0, col) = .Name & "!" & w.Name Else col = col - 1 'titre ou annulation
                R = ""
                For Each R In R.Offset(1)
                    If R Like "*--*" Then R = ""
            Next R, w
            .Close True 'enregistre et ferme le fichier
        End With
    End If
    PC = Dir
Wend
source(0, 3).Resize(, Columns.Count - 2).Columns.AutoFit 'ajustement largeurs
End Sub

 

[job75]

Bonjour EXCJPH, le forum,

Il y a encore 2 choses à régler :

- chez moi Dir(chemin & "\*.xls") récupère aussi les fichiers .xlsm, .xlsb...

- cette instruction n'est pas acceptée sur MAC.

Utilisez donc ce fichier (6) avac :

PC = Dir(chemin & Application.PathSeparator) ' premier fichier
'-----
While PC <> ""
    If PC <> ThisWorkbook.Name And Right(fichier, 4) = ".xls" Then

A+

 

[EXCJPH]

Bonjour EXCJPH, le forum,

Il y a encore 2 choses à régler :

- chez moi Dir(chemin & "\*.xls") récupère aussi les fichiers .xlsm, .xlsb...

- cette instruction n'est pas acceptée sur MAC.

Utilisez donc ce fichier (6) avac :

PC = Dir(chemin & Application.PathSeparator) ' premier fichier
'-----
While PC <> ""
    If PC <> ThisWorkbook.Name And Right(fichier, 4) = ".xls" Then

A+

Bonjour job75 et le Forum
Oui j'avais remarqué ce bug sur le Dir(chemin & "\*.xls"). Votre nouvelle instruction corrige parfaitement ce petit désagrément.
Mon projet, grâce à vous est ficelé. J'avais déjà, en souvenir, il y a longtemps, téléchargé quelques codes issus de votre cerveau comme "DateFin". Je savais bien que votre nom me disait quelque chose.
Alors encore Merci. Quel honneur et quel plaisir d'avoir croisé votre chemin VBA. A travers ces messages ou les instructions pleuvent, je perçois une personne de qualité et compétente qui va bien au delà de tout cela.
Bien à vous