Enregistrement de fichiers suite a une recherche et modification

bonjour a tous

mon fichier actuellement effectues une recherche dans plusieurs fichiers d'un dossier

j'aimerais ajouter un bouton pour effectuer enregistrement des modifications que j'aurais apporter couleur de cellule et non du client en colonne affaire/client

Sub Recherche()
Dim cible$, entete, fso As Object, dossier As FileDialog, sf$, lig&, f As Object, wb As Workbook, plage As Range, col, j%, c As Range, cc As Range, dercol%, i&
cible = "*" & [G1].Text & "*"
entete = Array("S/N", "Pallet No.") 'les 2 colonnes à étudier
Set fso = CreateObject("Scripting.FileSystemObject")
ChDir ThisWorkbook.Path 'dossier initial
Set dossier = Application.FileDialog(msoFileDialogFolderPicker)
If dossier.Show = False Then [B1] = "": Exit Sub
sf = dossier.SelectedItems(1) & "\"
[B1] = sf
Application.ScreenUpdating = False
With Sheets("Feuil1").[A3].CurrentRegion 'nom de la feuille à adapter
    .Offset(1).Delete xlUp 'RAZ
    lig = 2
    For Each f In fso.Getfolder(sf).Files
        Set wb = Workbooks.Open(sf & f.Name) 'ouverture du fichier
        Set plage = ActiveSheet.Range("A1", ActiveSheet.UsedRange)
        ReDim col(1)
        For j = 0 To 1
            Set c = plage.Find(entete(j), , xlValues, xlWhole)
            If c Is Nothing Then MsgBox "En-tête non trouvée dans " & wb.Name: GoTo 1
            col(j) = c.Column
        Next j
        Set cc = plage.Find("AFFAIRE/CLIENT")
        If cc Is Nothing Then dercol = 0 Else dercol = cc.Column
        For i = c.Row + 1 To plage.Rows.Count
            For j = 0 To 1
                If plage(i, col(j)) <> "" Then
                    If plage(i, col(j)).Text Like cible Then
                        If .Cells(lig, 1) = "" Then .Hyperlinks.Add .Cells(lig, 1), sf & f.Name, TextToDisplay:=f.Name 'lien hypertecte
                        .Cells(lig, j + 2) = plage(i, col(j))
                        If plage(i, dercol) <> "" Then .Cells(lig, j + 2).Interior.ColorIndex = 6 'jaune
                    End If
                End If
            Next j
            If .Cells(lig, 1) <> "" Then
                If dercol Then .Cells(lig, 4) = plage(i, dercol)
                .Cells(lig, 5) = i
                lig = lig + 1
            End If
        Next i
1       wb.Close False 'fermeture du fichier
    Next f
    .EntireColumn.AutoFit 'ajustement largeurs
    With .Parent.UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub

merci d'avance

5recherche11.zip (384.89 Ko)
Rechercher des sujets similaires à "enregistrement fichiers suite recherche modification"