VBA comment récupérer les données de plusieurs fichiers excel.

icecube - 3 janv. 2018 à 14:45 - Dernière réponse : gbinforme 14523 Messages postés lundi 18 octobre 2004Date d'inscriptionContributeurStatut 7 janvier 2018 Dernière intervention
- 4 janv. 2018 à 11:57
bonjour,

j'ai une macro qui permet d'ouvrir une boite de dilaogue celle ci me permet de sélectionner un fichier excel, cette macro ouvre le fichier pour appliquer un filtre sur la feuil "codax" et elle copie le résultat du filtre et le coller sur le fichier où la macro est écrite (feuil1).

du coup aujourd'hui on me demande de faire on sorte de pouvoir sélectionner plusieurs fichiers on va dire 30 et la macro fera la même chose.

pouvez m'aider car même si j'ai mis le multiselect a true, ca me preen unisuement les données du premier ficher donc les 29 autre ne sont meme pris en compte par la macro. En vous remrciant para avance

Option Explicit

Sub ouvrirtest()
    Application.EnableEvents = False
    'Application.Calculation = xlCalculateManual
    Dim wbsrc As Excel.Workbook ' déclarer le fichier source
    Dim wbtrg As Excel.Workbook ' déclarer le fichier detinataire
    Dim ws As Excel.Worksheet   ' declarer les feuil
    Dim strFileName As String
    Dim intChoice As Integer   'Déclarer les variables de base
    Application.ScreenUpdating = False
    Application.Cursor = xlWait
    
    Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = True
    intChoice = Application.FileDialog(msoFileDialogOpen).Show
    If intChoice <> 0 Then
    strFileName = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
    Workbooks.Open strFileName
    Set wbsrc = ActiveWorkbook
    Else
    MsgBox "La procédure est annulée car aucun fichier n’a été entré."
    Exit Sub
    End If
    'Set wbsrc = Application.Workbooks.Open("C:\Users\tabello\Mes documents locaux\outil compta-risk\F_Comparaison\COMPARISON_1505.xlsx") ' ouvrir le fichier source
    Set wbtrg = ThisWorkbook ' dire que c'est sur ce fichier que je travail
    
    Set ws = wbsrc.Worksheets("CODAX") ' lancer le filtre sur la colonne 4
    ws.Range("A6:T400").AutoFilter Field:=3, Criteria1:=RGB(130, 190, 0), Operator:=xlFilterCellColor
    ws.Range("A6:W400").Copy ' copie le résultat du filtre
      
    Set ws = wbtrg.Worksheets("Feuil1")  ' coller le resultat dans la feuil source du fichier destinataire
    ws.Range("A1").PasteSpecial xlPasteAll
    ws.Columns("A:T").ColumnWidth = 15
    ws.Rows("1:1").RowHeight = 70
    ws.Rows("2:100").RowHeight = 15
    Set ws = Nothing
    Application.DisplayAlerts = False
    wbsrc.Close savechanges:=False  ' fermer le fichier source
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Set wbsrc = Nothing
    Set wbtrg = Nothing
    Application.Cursor = xlDefault
    'ActiveWorkbook.Sheets("PAGE d'ACCUEIL").Activate
    'Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
         MsgBox "Import terminé"
End Sub


Afficher la suite 

5 réponses

Répondre au sujet
gbinforme 14523 Messages postés lundi 18 octobre 2004Date d'inscriptionContributeurStatut 7 janvier 2018 Dernière intervention - 3 janv. 2018 à 16:07
0
Utile
Bonjour,

Il te faut faire une boucle sur SelectedItems(x) avec x = 1 to SelectedItems.count pour récupérer tous les classeurs choisis.
Commenter la réponse de gbinforme
0
Utile
1
bonjour, merci pour ta réponse!

est ce que tu peux intégrer cet boucle dans ma macro, car je suis très mauvais lorsqu'il faut écrire des boucles.
merci
gbinforme 14523 Messages postés lundi 18 octobre 2004Date d'inscriptionContributeurStatut 7 janvier 2018 Dernière intervention - 3 janv. 2018 à 17:43
Bonsoir,

Ta macro avec la boucle :
Option Explicit
Sub ouvrirtest()
    Application.EnableEvents = False
    Dim wbsrc As Excel.Workbook ' déclarer le fichier source
    Dim wbtrg As Excel.Workbook ' déclarer le fichier detinataire
    Dim ws As Excel.Worksheet   ' declarer les feuil
    Dim wk As Excel.Worksheet   ' declarer les feuil
    Dim intChoice As Integer   'Déclarer les variables de base
    Dim fic As Integer
    Application.ScreenUpdating = False
    Application.Cursor = xlWait
    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = True
        intChoice = .Show
        If intChoice <> 0 Then
            Set wbtrg = ThisWorkbook ' dire que c'est sur ce fichier que je travail
            Set ws = wbtrg.Worksheets("Feuil1")  ' coller le resultat dans la feuil source du fichier destinataire
            For fic = 1 To .SelectedItems.Count
                Workbooks.Open .SelectedItems(fic)
                Set wbsrc = ActiveWorkbook
                Set wk = wbsrc.Worksheets("CODAX") ' lancer le filtre sur la colonne 4
                wk.Range("A6:T400").AutoFilter Field:=3, Criteria1:=RGB(130, 190, 0), Operator:=xlFilterCellColor
                wk.Range("A6:W400").Copy ' copie le résultat du filtre
                ws.Cells(ws.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Paste
                wbsrc.Close savechanges:=False  ' fermer le fichier source
            Next fic
            ws.Columns("A:T").ColumnWidth = 15
            ws.Rows("1:1").RowHeight = 70
            ws.Rows("2:100").RowHeight = 15
            Set ws = Nothing
            Set wbsrc = Nothing
            Set wbtrg = Nothing
        Else
            MsgBox "La procédure est annulée car aucun fichier n’a été entré."
            Exit Sub
        End If
    End With
    Application.ScreenUpdating = True
    Application.Cursor = xlDefault
    Application.EnableEvents = True
    MsgBox "Import terminé"
End Sub
Commenter la réponse de icecube
0
Utile
1
bonjour,

je te remercie beaucoup pour le code, ça marche nickel.

très content merci beaucoup

désolé pour la réponse tardive. ;)
gbinforme 14523 Messages postés lundi 18 octobre 2004Date d'inscriptionContributeurStatut 7 janvier 2018 Dernière intervention - 4 janv. 2018 à 11:57
Merci du retour et bonne continuation
Commenter la réponse de icecube