recherche multi-classeur

[mic41]

bonjour,

je parcours actuellement tous les classeurs se trouvant dans un dossier et je vérifie dans chacun des onglet si je trouve une valeur (entrée en variable).
Mon code va bien m'ouvrir les classeurs, mais il ne trouve pas toujours la valeur désirée dans les onglets et la recopie dans le classeur de destination ne se fait pas comme je le voudrais, c'est à dire à la suite.

Je vous joins le code sur lequel je travaille actuellement en espérant que quelqu'un puisse repérer une éventuelle faille.

Function trouve()
Windows("classeuracompiler").Activate
Sheets("Feuille2").Select
Range("A10").Activate
societe = ActiveCell.Value
End Function

Sub essai2()

trouve
Dim wb As Workbook, classeurDestination As Workbook
Dim Ws As Worksheet
Dim fichier As String, chemin As String
Dim celluletrouvee As Range

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set classeurDestination = ThisWorkbook

chemin = "C:\..."
fichier = Dir(chemin & "*.xls")

Do While fichier <> ""
Set wb = Workbooks.Open(chemin & fichier)
For Each Ws In wb.Worksheets
Set celluletrouvee = Range("A1:O300").Find(societe, lookat:=xlWhole)
If celluletrouvee Is Nothing Then
GoTo suite
Else
celluletrouvee.CurrentRegion.Copy
Windows("classeuracompiler.xls").Activate
Sheets("Feuille1").Activate
Range("C1").End(xlDown).Activate
ActiveCell.Offset(1, 0).Activate
ActiveSheet.Paste
End If
GoTo suite
suite:
Next Ws

Application.ScreenUpdating = True
Application.DisplayAlerts = True
wb.Close False
Set wb = Nothing
Set classeurDestination = Nothing
fichier = Dir
Loop
End Sub

Merci pour votre aide

mic

 

[YANN-56]

Re : recherche multi-classeur

Bonsoir Mic, et à ceux qui passeront par ici,

Il n'est pas trop difficile d'ouvrir successivement les Classeurs
d'un répertoire, et d'en visiter l'une ou l'autre des cellules.

Mais quant à chercher dans tous les onglets et toutes les cellules,
cela reste possible, mais tu compliques un peu trop, et cela serait long.

Il serait certainement souhaitable que ces Classeurs aient la même structure.
pour en limiter la recherche.

Ceci étant dit, je reste disponible sous réserve d'avoir un exemple
de ta base de données (Dossier où tu fouilles... Minimisé Bien entendu!)

Amicalement.

Yann

 

[mic41]

Re : recherche multi-classeur

bonjour yann,

Le classseur "recomposition equipe" est celui qui contient le code et a partir duquel nous allons ouvrir les classeurs pour aller chercher la valeur désirée.

Le classeur1 est le classeur cible et contient des plannings (tableaux qui ont la même structure) mais pas toujours placés au même endroit dans l'onglet.

La valeur cible quand à elle sera toujours une cellule fusionnée. Le résultat que je souhaite obtenir se trouve en feuille 3 du classeur recomposition equipe.

J'attends de tes nouvelles en cas de trouvaille et bien sûr merci de t'interesser a mon problème.

mic

 

[mic41]

Re : recherche multi-classeur

Bonjour a tous,

Je viens de trouver l'astuce pour coller proprement mes données : voila le code vba que j'utilise (seulement une ligne en plus qui est le retour vers le classeur où on va chercher le planning
J'ai egalement rajouté le nom d'onglet auquel appartient le planning pour etre sur que la macro va chercher dans tous les onglets.

Sub essai2()

trouve
Dim wb As Workbook, classeurDestination As Workbook
Dim Ws As Worksheet
Dim fichier As String, chemin As String
Dim celluletrouvee As Range
Dim onglet As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set classeurDestination = ThisWorkbook

chemin = "C:\Users\Olivier\Documents\Skills manager\planning fominvest\planning neo\"
fichier = Dir(chemin & "*.xls")

Do While fichier <> ""
Set wb = Workbooks.Open(chemin & fichier)
For Each Ws In wb.Worksheets
onglet = Ws.Name
Set celluletrouvee = Range("A1:O300").Find(societe, lookat:=xlWhole)
If celluletrouvee Is Nothing Then
GoTo suite
Else
celluletrouvee.CurrentRegion.Copy
Windows("Recomposition Equipe 2008-2009.xlsm").Activate
Sheets("Feuille1").Activate
Range("C1").Select
Selection.End(xlDown).Activate
ActiveCell.Offset(1, 0).Activate
ActiveSheet.Paste
ActiveCell.Offset(0, 1).Value = onglet
Windows(fichier).Activate End If
suite:
Next Ws

Application.ScreenUpdating = True
Application.DisplayAlerts = True
wb.Close False
Set wb = Nothing
Set classeurDestination = Nothing
fichier = Dir
Loop
End Sub

C'est tres artisanal mais ca marche