XL 2016 Lire dans classeurs fermés et copie si trouve

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Bonjour à toutes et à tous,

Me voici devant un nouveau souci de codification que je ne sais vraiment pas faire.
Malgré mes recherches j'ai pas trouvé de solution sur le site et sur le net.
J'ai tenté beaucoup de codes que j'ai tenté d'adapter sans succès.

Je ne tourne "naturellement" LOL vers nos ténors toujours si efficaces pour solliciter de l'aide.

Voici mon problème :
ici, pour l'exemple, j'ai créé 3 classeurs (si solution il y a, il me sera facile de modifier pour inclure tous les classeurs dans le code)

Je souhaiterai qu'à partir du fichier "Import_Valeur_Cherchée" onglet "Résultat" :

1 - je clique sur le bouton "recherche",
2 - je colle le N° qui appelle,
3 - le code va lire tous les classeurs (fermés) et s'il trouve, il me copie la ligne (où les lignes si plusieurs) dans ce classeur dans l'onglet "Résultat"

Pour tests codes, je joins les classeurs :
Import_Valeur_Cherchée (qui contient dans l'onglet "Ce que je voudrais faire", l'explication détaillée de mon besoin)
Classeur_1 - Classeur_2 - Classeur_3
+ classeur qui contient d’excellents codes de SilkyRoad qui me semblent proches de mon besoin.

En espérant que vous pourrez, une nouvelle fois m'aider et vous en remerciant,
Je vous souhaite à toutes et à tous une très belle journée.
Amicalement,
Lionel,
 

Pièces jointes

  • Classeur_1.xlsm
    11.5 KB · Affichages: 12
  • Classeur_2.xlsm
    11.5 KB · Affichages: 11
  • Classeur_3.xlsm
    11.5 KB · Affichages: 9
  • SilkyRoad.xlsm
    22.4 KB · Affichages: 16
  • Import_Valeur_Cherchée.xlsm
    25.4 KB · Affichages: 15
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour Lionel,

S'il n'y a pas trop de fichiers il est bien plus simple de les ouvrir, de les traiter et de les refermer :
VB:
Sub Recherche()
Dim tel$, chemin$, fichier$, resu(), tablo, i&, n&, j%
tel = InputBox("Entrez le numéro de téléphone recherché :")
If tel = "" Then Exit Sub
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "*.xls*")
ReDim resu(1 To Rows.Count, 1 To 27)
Application.ScreenUpdating = False
While fichier <> ""
    If fichier <> ThisWorkbook.Name Then
        With Workbooks.Open(chemin & fichier).Sheets("Donnees")
            tablo = Intersect(.UsedRange.EntireRow, .[I:AI]) 'matrice, plus rapide
                For i = 1 To UBound(tablo)
                    If CStr(tablo(i, 6)) = tel Or CStr(tablo(i, 7)) = tel Then
                        n = n + 1
                        For j = 1 To 27
                            resu(n, j) = tablo(i, j)
                        Next j
                    End If
                Next i
            .Parent.Close False
        End With
    End If
    fichier = Dir
Wend
'---restitution---
With [I2] 'cellule à adapter
    If n Then .Resize(n, 27) = resu
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 27).ClearContents 'RAZ en dessous
End With
End Sub
A+
 
Dernière édition:

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Bonjour Gérard,,

Content de te revoir :)
Merci pour ton code.

"S'il n'y a pas trop de fichiers il est bien plus simple de les ouvrir, de les traiter et de les refermer :"

C'est ce que je fais depuis le début mais les fichiers sont lourds et quand un prospect appelle, il faut agir vite?

C'est pour cela que ce serait génial que ça puisse fonctionner.
Je teste et je reviens :)
Lionel,
 

zebanx

XLDnaute Accro
Bonjour arthour973, Job75

Par rapport à la structure des fichers (tableau double entrée, structuration identique, besoin de nombreux enregistrements), ne serait-il pas envisageable de tout passer sur "access" plutôt qu'excel ?

Bonne journée à tous les deux
 

zebanx

XLDnaute Accro
Re

Le temps toujours.
C'est sûr que c'est mieux de sonder un peu dans l'entourage si quelqu'un connait access pour montrer l'utilité.
Ou de s'auto-fermer. Il faut en avoir le temps et la motivation.
En attendant, JOB75... permettent "de" donc... ça va

Bonne journée :cool:
zebanx
 

job75

XLDnaute Barbatruc
Bonjour Lionel, le forum,

Pour gagner du temps on peut ouvrir les fichiers et ne plus les fermer :
VB:
Public Ouvre As Boolean 'mémorise la variable

Sub Recherche()
Dim tel$, chemin$, fichier$, resu(), F As Worksheet, tablo, i&, n&, j%
If Ouvre Then tel = Chr(1) Else tel = InputBox("Entrez le numéro de téléphone recherché :")
If tel = "" Then Exit Sub
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "*.xls*")
ReDim resu(1 To Rows.Count, 1 To 27)
Application.ScreenUpdating = False
On Error Resume Next
While fichier <> ""
    If fichier <> ThisWorkbook.Name Then
        Set F = Nothing: Set F = Workbooks(fichier).Sheets("Donnees")
        If F Is Nothing Then Set F = Workbooks.Open(chemin & fichier).Sheets("Donnees"): ActiveWindow.WindowState = xlMinimized
        tablo = Intersect(F.UsedRange.EntireRow, F.[I:AI]) 'matrice, plus rapide
        For i = 1 To UBound(tablo)
            If CStr(tablo(i, 6)) = tel Or CStr(tablo(i, 7)) = tel Then
                n = n + 1
                For j = 1 To 27
                    resu(n, j) = tablo(i, j)
                Next j
            End If
        Next i
    End If
    fichier = Dir
Wend
'---restitution---
With Feuil1.[I2] 'cellule à adapter
    If n Then .Resize(n, 27) = resu
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 27).ClearContents 'RAZ en dessous
    .Parent.Parent.Activate
End With
End Sub
Ouvertures et fermetures des fichiers par ces codes dans ThisWorkbook :
VB:
Private Sub Workbook_Open()
Ouvre = True: Recherche: Ouvre = False
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim w As Workbook
For Each w In Workbooks
    If w.Name <> Me.Name Then w.Close True
Next
Me.Save
Application.Quit
End Sub
J'ai testé avec 3 fichiers sources de 18 000 lignes : l'exécution se fait en 0,8 seconde.

A+
 

Pièces jointes

  • Classeur_1.xlsm
    16.8 KB · Affichages: 4
  • Classeur_2.xlsm
    16.8 KB · Affichages: 5
  • Classeur_3.xlsm
    16.8 KB · Affichages: 4
  • Import_Valeur_Cherchée(1).xlsm
    29.7 KB · Affichages: 2
Dernière édition:

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Re-Bonjour Gérard, le forum,

J'ai testé LOL

Le second code chez moi (post 10) est plus long a exécuter.
Cela doit provenir du temps à ouvrir les fichiers qui ne contiennent pas 180.000 lignes mais beaucoup de colonnes avec formules et longs à ouvrir.

Ne m'en veut pas mais je préfère le 1er code car il n'affiche que le fichier "Import_Valeur_Cherchée" et plus rapide chez moi.

Résultats de mes tests :
Temps pour trouver la ligne contenant le N° à chercher, comme je faisais avant en ouvrant les fichiers et en recherchant dans chaque fichier :
entre 1 et 2 minutes


Temps avec le fichier "Import_Valeur_Cherchée" qui contient ton code post2 :

entre 35 et moins d'une minute
Ton code fonctionne nickel et c'est déjà un gain de temps important qui me permet de savoir rapidement de quoi je vais parler avec mon interlocuteur.

Toutefois, j'aurai besoin d'un temps de réaction encore plus rapide LOL

Je pense que c'est du à l'ouverture et fermeture des fichiers
Le temps à ouvrir les fichiers est long (ils ne contiennent pas 180.000 lignes mais beaucoup de colonnes avec formules).

Serait-il possible d'exécuter le code sans ouvrir les fichiers ?
Cela devrait encore réduite le temps d'exécution.

Mais si pas possible ou si trop de temps à passer pour toi, je resterai sur ton code (post2)
qui déjà m'apporte beaucoup et qui fonctionne super bien :)


Un grand merci Gérard :)
Lionel,
 

job75

XLDnaute Barbatruc
Le code post #10 ouvre les fichiers sources uniquement à l'ouverture du fichier Import_Valeur_Cherchée(1).xlsm.

Ensuite quand on clique sur le bouton pour faire une recherche l'exécution est forcément plus rapide qu'au post #2 puisque les fichiers sont déjà ouverts.
 

Discussions similaires

Statistiques des forums

Discussions
311 723
Messages
2 081 932
Membres
101 844
dernier inscrit
pktla