Recherche dans plusieurs Fichiers Excel avec VBA

elbarja · 9 Octobre 2017

Bonjour le Forum,

SVP, j'ai besoin de votre aider créer une macro pour faire une recherche dans des fichiers Excel et copier le résultat dans un fichier Excel appelé résultat.
Je vous explique mon problème comme suit :

J'ai 3 fichiers Excel : fichier de base, fichier de rejet2016 et fichier de résultat.
A partir du fichier rejet2016, qui composé de plusieurs onglet contenant les 12 mois de 2016, dans chaque onglet je veux prendre les valeurs qui existent dans la colone "B" et les rechercher dans le fichier de base qui contient en fait 2 onglets Feuil1 et Feuil2 ( la recherche va se faire dans les 2 onglets), après si je trouve la valeur dans l'un des ongelts alors il faut copier la ligne qui contient cette valeur dans le fichier résultat avec quelques régles à aplliquer dans le fichier résultat.

Par exemple si je trouve la valeur dans le fichier de base alors la colone "G" du fichier résultat égale à la somme des colonnes "G" et "L" du fichier de base.
La colonne "F" du fichier résultat est égale à la multiplication de la colonne "E" et la colonne "G" du même fichier résultat
Les colonnes "K" ; "L" et "M" sont figés par les valeurs suivantes :
"K" = 01/01/2016
"L" = 01/08/2017
"M"= 20
Dans le fichier résultat : la colonne "N" est égale à la multiplication de la colonne "M" et la colonne "E"
et si la valeur recherchée n'existe pas dans le fichier de base (dans les 2 onglets), alors:
je copie dans le fichier résultat la valeur recherché dans la colonne "B" et
dans la colonne "E" du fichier résultat je copie la valeur du colonne "F" du fichier rejet2016
et dans le fichier résultat, la colonne "I" je mets le mois exemple (01/05/2016) équivalent à l'onglet du mois et dans le colonne "H" je mets le mois-1 exemple (01/04/2016)

Je mets à votre disposition les fichiers comme exemple, svp aidez moi.

Cordialement

CHALET53 · 10 Octobre 2017

Bonjour,

Un essai (un peu usine à gaz)
Installer ce fichier dans un même répertoire avec les deux autres (sans autres fichiers)
Toujours lancer la macro à partir du bouton "Lance"
a+

elbarja · 10 Octobre 2017

Bonjour,

Merci pour ton retour, mais lorsque je lance la macro le fichier résultat ne contient aucun donnée.

est ce que la macro est appliquée sur un onglet ou bien tous les onglets ?

Merci

CHALET53 · 10 Octobre 2017

Chez moi, cela fonctionne
Les trois fichiers sont bien dans le même répertoire ?
Lorsque tu lances la macro, :
elle ouvre les deux fichiers (Fichier de base et Résultat)
et
exécute la macro qui passe en revue toutes les lignes du Fichier de base, vérifie dans le fichier Rejet2016 sur tous les mois et écrit dans le fichier Résultat (feuille Résultat)
Après exécution, les 3 fichiers doivent être ouverts

job75 · 10 Octobre 2017

Bonsoir elbarja, CHALET53,

C'est un peu laborieux mais finalement amusant de suivre scrupuleusement les indications du post #1 :

Code:

Sub Résultat()
Dim chemin, Base As Workbook, F As Worksheet, a(), n&
Dim w As Worksheet, c As Range, lig&, flag As Boolean, dat
chemin = ThisWorkbook.Path & "\" 'adapter si nécessaire
'---ouverture des 2 fichiers---
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier est déjà ouvert
Set Base = Workbooks.Open(chemin & "Fichier de base.xlsx") 'adapter si nécessaire
Set F = Workbooks.Open(chemin & "Résultat.xlsx").Sheets("Résultat") 'adapter si nécessaire
F.Rows("2:" & F.Rows.Count).Delete 'RAZ
On Error Resume Next 's'il n'y a pas de SpecialCell
'---liste des valeurs à rechercher avec doublons en colonne B des feuilles---
For Each w In ThisWorkbook.Worksheets
  For Each c In w.Columns("B").SpecialCells(xlCellTypeConstants)
    If IsNumeric(c) Then
      n = n + 1
      ReDim Preserve a(1 To 3, 1 To n)
      a(1, n) = CStr(c)
      a(2, n) = c(1, 5) 'colonne F
      a(3, n) = w.Name
    End If
Next c, w
If n = 0 Then GoTo 1
'---recherche des valeurs en colonnes B de Base et traitement de F---
lig = 2
For n = 1 To UBound(a, 2)
  flag = True
  For Each w In Base.Worksheets
    For Each c In w.Columns("B").SpecialCells(xlCellTypeConstants)
      If CStr(c) = a(1, n) Then
        c(1, 0).Resize(, 13).Copy F.Cells(lig, 1) '13 cellules copiées
        F.Cells(lig, "I").Insert xlToRight 'insertion d'une cellule pour décaler
        F.Cells(lig, "G") = Val(c(1, 6)) + Val(c(1, 11))
        F.Cells(lig, "F") = Val(Replace(F.Cells(lig, "E"), ",", ".")) * F.Cells(lig, "G")
        F.Cells(lig, "K") = CDate("1/1/2016") 'donnée modifiable
        F.Cells(lig, "L") = CDate("1/8/2017") 'donnée modifiable
        F.Cells(lig, "M") = 20 'donnée modifiable
        F.Cells(lig, "N") = Val(Replace(F.Cells(lig, "E"), ",", ".")) * F.Cells(lig, "M")
        lig = lig + 1
        flag = False
      End If
  Next c, w
  If flag Then
    F.Cells(lig, "B") = a(1, n)
    F.Cells(lig, "E") = a(2, n)
    dat = LCase(Application.Trim(a(3, n))) 'SUPPRESPACE + minuscules
    dat = Mid(dat, InStr(dat, " ") + 1)
    dat = "1 " & Replace(Replace(Replace(dat, "fev", "fév"), "aout", "août"), "dec", "déc")
    If IsDate(dat) Then
      F.Cells(lig, "I") = CDate(dat)
      F.Cells(lig, "H") = DateSerial(Year(dat), Month(dat) - 1, 1) 'mois précédent
    End If
    lig = lig + 1
  End If
Next n
With F.[A1].CurrentRegion
  .Sort .Columns(2), xlAscending, .Columns(8), , xlAscending, Header:=xlYes 'tri sur 2 colonnes
  .Borders.Weight = xlThin 'bordures
End With
1 Base.Close
F.Visible = xlSheetVisible 'au cas où...
F.Parent.Save 'enregistrement
Application.Goto F.[A1], True 'cadrage
End Sub

Nota : les noms des onglets de JUIN et NOVEMBRE étaient erronés, j'ai corrigé.

Télécharger les 3 fichiers joints dans le même dossier (le bureau).

Bonne nuit.

job75 · 11 Octobre 2017

Bonjour le fil, le forum,

Voici cette fois la solution sans doublon, traitée par le Dictionary :

Code:

Sub Résultat()
Dim chemin, Base As Workbook, F As Worksheet, d As Object
Dim w As Worksheet, c As Range, a, b, lig&, i&, flag As Boolean, s, dat
chemin = ThisWorkbook.Path & "\" 'adapter si nécessaire
'---ouverture des 2 fichiers---
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier est déjà ouvert
Set Base = Workbooks.Open(chemin & "Fichier de base.xlsx") 'adapter si nécessaire
Set F = Workbooks.Open(chemin & "Résultat.xlsx").Sheets("Résultat") 'adapter si nécessaire
F.Rows("2:" & F.Rows.Count).Delete 'RAZ
On Error Resume Next 's'il n'y a pas de SpecialCell
'---liste des valeurs à rechercher sans doublon en colonne B des feuilles---
Set d = CreateObject("Scripting.Dictionary")
For Each w In ThisWorkbook.Worksheets
  For Each c In w.Columns("B").SpecialCells(xlCellTypeConstants)
    If IsNumeric(c) And Not d.exists(CStr(c)) Then d(CStr(c)) = c(1, 5) & Chr(1) & w.Name 'mémorisation colonne F et mois
Next c, w
If d.Count = 0 Then GoTo 1
'---recherche des valeurs en colonnes B de Base et traitement de F---
a = d.keys: b = d.items
lig = 2
For i = 0 To UBound(a)
  flag = True
  For Each w In Base.Worksheets
    For Each c In w.Columns("B").SpecialCells(xlCellTypeConstants)
      If CStr(c) = a(i) Then
        c(1, 0).Resize(, 13).Copy F.Cells(lig, 1) '13 cellules copiées
        F.Cells(lig, "I").Insert xlToRight 'insertion d'une cellule pour décaler
        F.Cells(lig, "G") = Val(c(1, 6)) + Val(c(1, 11))
        F.Cells(lig, "F") = Val(Replace(F.Cells(lig, "E"), ",", ".")) * F.Cells(lig, "G")
        F.Cells(lig, "K") = CDate("1/1/2016") 'donnée modifiable
        F.Cells(lig, "L") = CDate("1/8/2017") 'donnée modifiable
        F.Cells(lig, "M") = 20 'donnée modifiable
        F.Cells(lig, "N") = Val(Replace(F.Cells(lig, "E"), ",", ".")) * F.Cells(lig, "M")
        lig = lig + 1
        flag = False
      End If
  Next c, w
  If flag Then
    F.Cells(lig, "B") = a(i)
    s = Split(b(i), Chr(1))
    F.Cells(lig, "E") = Val(Replace(s(0), ",", "."))
    dat = LCase(Application.Trim(s(1))) 'SUPPRESPACE + minuscules
    dat = Mid(dat, InStr(dat, " ") + 1)
    dat = "1 " & Replace(Replace(Replace(dat, "fev", "fév"), "aout", "août"), "dec", "déc")
    If IsDate(dat) Then
      F.Cells(lig, "I") = CDate(dat)
      F.Cells(lig, "H") = DateSerial(Year(dat), Month(dat) - 1, 1) 'mois précédent
    End If
    lig = lig + 1
  End If
Next i
With F.[A1].CurrentRegion
  .Sort .Columns(2), xlAscending, Header:=xlYes 'tri
  .Borders.Weight = xlThin 'bordures
End With
1 Base.Close
F.Visible = xlSheetVisible 'au cas où...
F.Parent.Save 'enregistrement
Application.Goto F.[A1], True 'cadrage
End Sub

C'est la première occurrence trouvée dans les feuilles qui est retenue.

Ces feuilles doivent donc être toujours placées dans l'ordre chronologique.

Bonne journée.

elbarja · 12 Octobre 2017

Bonsoir,

Merci pour ton retour, et mille merci pour ton aide.

la macro fonctionne parfaitement, encore merci pour ton aide.

Et merci le forum.

elbarja · 17 Octobre 2017

Bonjour Job75, le forum,

J'aurais Svp besoin d'un petit Help dans le même sujet, en fait dans le fichier résultat où on a figé la valeur des colonnes "L" et "M" par les valeurs (01/08/2017) et 20, je veux ajouter que :

Si je trouve la valeur dans le fichier de base alors je cherche cette valeur dans d'un autre fichier appelé rejet 2017 (en jointure à ce message composé de plusieurs onglets) pour remplir les colonnes "L" et "M" du fichier de résultat, dans ce cas la colonne "L" sera renseignée par le dernier mois qui contient cette valeur dans le fichier rejet 22017 par exemple le 01/08/2017 ou 01/07/207, Ou d'une autre manière je cherche directement la valeur trouvée dans le fichier de base dans l'onglet du mois aout de fichier rejet 2017 si je la trouve alors je mets 01/08/2017 si je ne la trouve pas je cherche dans l'onglet du mois m-1 et ainsi de suite jusqu'à ce que je trouve le dernier mois où elle apparait.

Pour la colonne "M" du fichier résultat sera en fait le nombre des mois entre la colonne "K" et "L" du même fichier, par exemple 20 si j'ai dans la colonne "L" = 01/08/2017 et "K" = 01/01/2017
ou 19 si j'ai dans la colonne "L" =01/07/2017 et "K" = 01/01/2017

Svp j'ai besoin de vos lumières en VBA.

Merci

job75 · 17 Octobre 2017

Bonjour elbarja, le forum,

Voyez le fichier (2) joint, j'ai complété le code comme suit :

Code:

        F.Cells(lig, "K") = CDate("1/1/2016") 'donnée modifiable
        F.Cells(lig, "L").Resize(, 3) = "" 'RAZ en colonnes L M N
        For j = Rejets.Worksheets.Count To 1 Step -1 'les feuilles doivent être placées en ordre chronologique
          Set c1 = Rejets.Worksheets(j).Columns("B").Find(c, , xlValues, xlWhole)
          If Not c1 Is Nothing Then
            dat = LCase(Application.Trim(Rejets.Worksheets(j).Name)) 'SUPPRESPACE + minuscules
            dat = Mid(dat, InStr(dat, " ") + 1)
            dat = "1 " & Replace(Replace(Replace(dat, "fev", "fév"), "aout", "août"), "dec", "déc")
            If IsDate(dat) Then
              F.Cells(lig, "L") = CDate(dat)
              F.Cells(lig, "M") = DateDiff("m", F.Cells(lig, "K"), dat) + 1 'nombre de mois
              F.Cells(lig, "N") = Val(Replace(F.Cells(lig, "E"), ",", ".")) * F.Cells(lig, "M")
              Exit For
            End If
          End If
        Next j

Remarques sur le fichier RejetS 2017.xls :

- les feuilles doivent toujours être placées en ordre chronologique croissant

- il y avait 2 espaces dans le nom, j'en ai enlevé un...

- pour éviter le message de mise à jour des liens à l'ouverture par la macro j'ai ajouté :

Code:

opt = Application.AskToUpdateLinks 'mémorise l'état
Application.AskToUpdateLinks = False 'évite le message de mise à jour des liens
'-----
Application.AskToUpdateLinks = opt 'état initial
End Sub

Bonne journée.

elbarja · 18 Octobre 2017

Merci job75 et merci le forum.

Effectuez une recherche sur Excel Downloads...

Recherche dans plusieurs Fichiers Excel avec VBA

elbarja

XLDnaute Nouveau

Pièces jointes

CHALET53

XLDnaute Barbatruc

Pièces jointes

elbarja

XLDnaute Nouveau

CHALET53

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

elbarja

XLDnaute Nouveau

elbarja

XLDnaute Nouveau

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

elbarja

XLDnaute Nouveau

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums