Import de données d'un fichier A vers un fichier B

Le 03/05/2022 à 10:25

Bonjour à tous,

Je vous sollicite aujourd'hui car, étant débutante sur VBA, je n'arrive pas à trouver mes erreurs.

Je voudrais, à partir de mon fichier source, importer toutes les informations des deux autres colonnes dans le fichier de destination à la condition que celles ci soit validée (colonne B =OK). J'ai un code de traitement et un code pour l'importation. Le code pour l'importation à l'air de fonctionner, celui de traitement pas du tout. Quelqu'un pourrait-il m'explique s'il vous plaît? Je suis débutant, je ne comprends pas encore grand chose...

4fichier-source.xlsm (10.90 Ko)
3fichier-de-destination.xlsm (20.49 Ko)
Option Explicit

Function TraitementFichier source(pathFile As String)
Dim wb As Workbook
Dim LastRow As Double
Dim cl As Variant
Dim row As Integer
row = 2
Set wb = GetObject(pathFile)
LastRow = wb.Sheets(1).Range("A" & Rows.Count).End(xlUp).row

With wb.Sheets(1).Range("B8:D" & LastRow)
.AutoFilter field:=2, Criteria1:="OK"

End With
For Each cl In wb.Sheets(1).Range("C2:C" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow
Debug.Print "test"
Application.ActiveWorkbook.Sheets(1).Cells(row, 1) = cl.Cells(1)
row = row + 1
Next cl

wb.Close SaveChanges:=False
End Function
Sub ImportFichiers1()
Dim fd As Office.FileDialog
Dim strFichier As String

Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Clear
.Filters.Add "Fichiers Excel", "*.xls", 1
.Title = "Choisissez un fichier Excel"
.AllowMultiSelect = False

.InitialFileName = "C:\"
If .Show = True Then
strFichier = .SelectedItems(1)
TraitementFichier1 strFichier
End If

End With

End Sub

Je vous remercie d'avance :-)

Le 03/05/2022 à 11:06

Bonjour mkleob et

Une petite présentation ICI serait la bienvenue

Si vous ne l'avez pas encore fait, je vous invite à lire la charte du forum [A LIRE AVANT DE POSTER]
qui vous aidera dans vos demandes et réponses sur ce forum et notamment :

  • Pour plus de lisibilité, utilisez la fonctionnalité </> pour insérer vos codes VBA (et si possible aussi pour vos formules Excel).
image

Merci de votre participation

Cordialement

Le 03/05/2022 à 11:19

Bonjour Bruno,

J'ai rédigé la présentation et ai modifié mon texte. Effectivement, c'est bien mieux comme ça, merci.

Cordialement,
Lucas

Le 03/05/2022 à 11:20

Bonjour le fil, bonjour le forum, bienvenue Mkleob,

Essai comme ça :

Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim EF As FileDialog 'déclare la variable EF (Explorateur de Fichiers)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
Dim I As Integer 'déclare la variable I (Incrément)
Dim K As Integer 'déclare la variable J (incrément)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CD = ThisWorkbook 'définit la classeur destination CD
Set OD = CD.Worksheets(1) 'définit l'onglet destination OD
OD.Range("B1").CurrentRegion.Offset(1, 0).ClearContents 'efface les anciennes valeurs de l'onglet destination
Set EF = Application.FileDialog(msoFileDialogOpen) 'définit l'explorateur de fichiers EF
EF.AllowMultiSelect = False 'n'autorise la sélection que d'un seul fichier
EF.Show 'affiche EF
If EF.SelectedItems.Count = 0 Then Exit Sub 'si aucun fichier n'est sélectionné, sort de la procédure
Set CS = Workbooks.Open(EF.SelectedItems(1)) 'définit le classeur source CS en l'ouvrant
Set OS = CS.Worksheets(1) 'définit l'onglet source OS
TV = OS.Range("B7").CurrentRegion 'définit le tableau des valeurs TV
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    If UCase(TV(I, 1)) = "OK" Then 'condition : si la donnée ligne I colonne 1 de TV (convertie en majuscules) est égale à "OK"
        K = K + 1 'incrémente K
        ReDim Preserve TL(1 To 3, 1 To K) 'redimensionne le tableau des lignes TL (3 lignes, K colonnes)
        TL(1, K) = TV(I, 1) 'récupère dans la ligne 1 de TL la donnée en colonne 1 de TV (=> Transposition)
        TL(2, K) = TV(I, 2) 'récupère dans la ligne 2 de TL la donnée en colonne 2 de TV (=> Transposition)
        TL(3, K) = TV(I, 3) 'récupère dans la ligne 3 de TL la donnée en colonne 3 de TV (=> Transposition)
    End If 'fin de la condition
Next I 'prochaine  ligne de la boucle
'si K est supérieure à zéro renvoie dans B2 redimensionnée de l'onglet OD, le tableau TL transposé
If K > 0 Then OD.Range("B2").Resize(K, 3) = Application.Transpose(TL)
CS.Close False 'ferme le classeur source sans enregistrer
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub
Le 03/05/2022 à 11:29

Bonjour à tous,

Une autre contribution, en utilisant un tableau structuré.

Option Explicit

Sub ImportFichiers1()

Dim fd As Office.FileDialog
Dim I As Integer, LastRow As Integer
Dim TabDest As ListObject
Dim LigneDest As ListRow
Dim AireRemontee As Range
Dim strFichier As Variant
Dim WbSource As Workbook
Dim ShDest As Worksheet, ShSource As Worksheet

    Set TabDest = Sheets("Feuil1").ListObjects("t_Destination")

    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Filters.Clear
        .Filters.Add "Fichiers Excel", "*.xlsm", 1
        .Title = "Choisissez un fichier Excel"
        .AllowMultiSelect = False

        .InitialFileName = ActiveWorkbook.Path & "\" '"C:\"
        If .Show = True Then
            strFichier = .SelectedItems(1)
        End If

    End With

    If strFichier = False Then Exit Sub

    Application.ScreenUpdating = False
    Set WbSource = Workbooks.Open(strFichier)
    Set ShSource = WbSource.Sheets(1)

    With ShSource
         LastRow = .Cells(.Rows.Count, "B").End(xlUp).row
         Set AireRemontee = .Range(.Cells(8, "B"), .Cells(LastRow, "B"))

         For I = 1 To AireRemontee.Count
             With AireRemontee(I)
                  If UCase(.Value) = "OK" Then
                     Set LigneDest = TabDest.ListRows.Add
                     LigneDest.Range(1, 1) = UCase(.Value)
                     LigneDest.Range(1, 2) = .Offset(0, 1)
                     LigneDest.Range(1, 3) = .Offset(0, 2)
                     With LigneDest.Range
                          .Font.ColorIndex = xlAutomatic
                          .Font.Bold = False
                     End With
                     Set LigneDest = Nothing
                  End If
             End With
         Next I
    End With

    WbSource.Close SaveChanges:=False
    Application.ScreenUpdating = True

    MsgBox "Import terminé !", vbInformation

    Set ShDest = Nothing: Set ShSource = Nothing
    Set WbSource = Nothing
    Set AireRemontee = Nothing
    Set fd = Nothing

End Sub
6mkleob-2022-05-03-ex-p-fichier-de-destination.xlsm (27.02 Ko)
Le 03/05/2022 à 11:57

Bonjour ThauThème et Eric Kergresse,

je vous remercie du fond du coeur pour votre aide, les deux codes fonctionnent très bien!

Je me permet deux questions complémentaires pour aller plus loin:

- Si je voudrais rajouter des colonnes dans mon fichier source et importer ces nouvelles données dans le fichier de destination, comment dois-je faire apparaitre cela dans le code? en rajoutant une ligne pour récupèrer dans la ligne 4 de TL la donnée en colonne 4 de TV si je prend le code de Thauthème par exemple?

- Si je voudrais importer des données de plusieurs onglets de départ vers plusieurs onglets de destination (onglet 1 fichier 1 vers onglet 1 fichier 2; onglet 2 fichier 1 vers onglet 2 fichier 2) , dois-je refaire un code pour chaque onglet ou un seul code pourrait être possible

Je vous remercie encore d'avoir pris de votre temps pour m'aider, vous êtes géniaux :-)

Le 03/05/2022 à 18:21

Bonjour le fil, bonjour le forum,

Pour mon approche, tu as bien cerné le problème. Il suffit de redimensionner TL en fonction du nombre x de colonnes :

Redim Preserve TL(1 to x, 1 to K)

puis de rajouter :

TL(x, K) = TV(I, x)

Pour ton dernier problème il est important de savoir où se trouvent les données. Si elles sont placées toujours au même endroit ça simplifie le code. Quoi qu'il en soit deux petits fichiers exemple seraient les bienvenus...

Le 04/05/2022 à 09:57
3fichier-de-destination.xlsm (28.90 Ko)
5fichier-source.xlsm (15.16 Ko)

Bonjour à tous,

Merci Thauthème pour ta réponse.

J'ai modifié le code comme ceux-ci et il fonctionne à merveille. Je vous remercie encore pour votre aide :-)

Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim EF As FileDialog 'déclare la variable EF (Explorateur de Fichiers)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
Dim I As Integer 'déclare la variable I (Incrément)
Dim K As Integer 'déclare la variable J (incrément)
Dim LastRowSource As Long
Dim RowDestination As Integer
RowDestination = 2
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CD = ThisWorkbook 'définit la classeur destination CD
Set OD = CD.Worksheets(1) 'définit l'onglet destination OD
OD.Range("B1").CurrentRegion.Offset(1, 0).ClearContents 'efface les anciennes valeurs de l'onglet destination
Set EF = Application.FileDialog(msoFileDialogOpen) 'définit l'explorateur de fichiers EF
EF.AllowMultiSelect = False 'n'autorise la sélection que d'un seul fichier
EF.Show 'affiche EF
If EF.SelectedItems.Count = 0 Then Exit Sub 'si aucun fichier n'est sélectionné, sort de la procédure
'Set CS = Workbooks.Open(EF.SelectedItems(1)) 'définit le classeur source CS en l'ouvrant
Set CS = GetObject(EF.SelectedItems(1))
Set OS = CS.Worksheets(1) 'définit l'onglet source OS

TV = OS.Range("B7").CurrentRegion 'définit le tableau des valeurs TV
LastRowSource = OS.Range("B" & Rows.Count).End(xlUp).row 'Cherche la dernière ligne contenant de la data

  With OS.Range("B8:F" & LastRowSource) ' Applique un filtre sur le tableau source (1er champ avec critere OK)
            .AutoFilter field:=1, Criteria1:="OK"

    End With
  For Each cl In OS.Range("C8:F" & LastRowSource).SpecialCells(xlCellTypeVisible).EntireRow 'Boucle sur les lignes qui reste visible après le filtre
        OD.Cells(RowDestination, 2) = "OK"
        OD.Cells(RowDestination, 3) = cl.Cells(3)
        OD.Cells(RowDestination, 4) = cl.Cells(4)
        OD.Cells(RowDestination, 5) = cl.Cells(5)
        OD.Cells(RowDestination, 6) = cl.Cells(6)
        RowDestination = RowDestination + 1
    Next cl

'si K est supérieure à zéro renvoie dans B2 redimensionnée de l'onglet OD, le tableau TL transposé
If K > 0 Then OD.Range("B2").Resize(K, 3) = Application.Transpose(TL)
 CS.Close SaveChanges:=False
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub

Comme je le disais, je voudrais maintenant faire ça mais avec différents onglets. Ce code correspond donc à l'import de l'onglet 1 du fichier 1 vers l'onglet 1 du fichier 2.

Je voudrais rajouter dans le code une boucle qui pourrait faire matcher deux onglets avec le même nom puis procéder à l'import pour faire qu'un seul et unique import et pour éviter d'avoir un code par onglet (dans mon vrai fichier, il y en a 30....). A votre avis, cela est-il possible?

Le 04/05/2022 à 15:01

Bonjour le fil, bonjour le forum,

Le code modifié qui s'adaptera tout seul au nombre de colonnes et qui parcours tous les onglets :

Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim EF As FileDialog 'déclare la variable EF (Explorateur de Fichiers)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim O As Integer 'déclare la variable O (Onglet)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim TD As ListObject 'déclare la variable TD (Tableau structuré Destination)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim TS As ListObject 'déclare la variabe TS (Tableau structuré Source)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
Dim I As Integer 'déclare la variable I (Incrément)
Dim K As Integer 'déclare la variable J (incrément)
Dim L As Byte 'déclare la variable L (incrément)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CD = ThisWorkbook 'définit la classeur destination CD
Set EF = Application.FileDialog(msoFileDialogOpen) 'définit l'explorateur de fichiers EF
EF.AllowMultiSelect = False 'n'autorise la sélection que d'un seul fichier
EF.Show 'affiche EF
If EF.SelectedItems.Count = 0 Then Exit Sub 'si aucun fichier n'est sélectionné, sort de la procédure
Set CS = Workbooks.Open(EF.SelectedItems(1)) 'définit le classeur source CS en l'ouvrant
For O = 1 To CS.Sheets.Count 'boucle 1 : sur tous les onglets O du classeur source
    Set OD = CD.Worksheets(O) 'définit l'onglet destination OD
    Set TD = OD.ListObjects(1) 'définit le tableau structuré destination TD
    Set OS = CS.Worksheets(O) 'définit l'onglet source OS
    Set TS = OS.ListObjects(1) 'définit le tableau structuré source TS
    If TD.ListRows.Count > 0 Then TD.DataBodyRange.Delete 'efface les données du tableau structuré destination TD s'il y en a
    TV = TS.DataBodyRange 'définit la tableau des valeurs TV
    For I = 1 To UBound(TV, 1) 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV
        If UCase(TV(I, 1)) = "OK" Then 'condition : si la donnée ligne I colonne 1 de TV (convertie en majuscules) est égale à "OK"
            K = K + 1 'incrémente K
            ReDim Preserve TL(1 To UBound(TV, 2), 1 To K) 'redimensionne le tableau des lignes TL (autant de lignes que TV a de colonnes, K colonnes)
            For L = 1 To UBound(TV, 2) 'boucle 3 : sur toutes les colonnes L du tableau des valeurs TV
                TL(L, K) = TV(I, L) 'récupère dans la ligne L de TL la donnée en colonne L de TV (=> Transposition)
            Next L 'prochaine colonne de le boucle 3
        End If 'fin de la condition
    Next I 'prochaine  ligne de la boucle 2
    If K > 0 Then 'condition : si K est supérieure à zéro
        TD.Resize TD.Range.Resize(K + 1, TD.ListColumns.Count) 'redimensionne le tableau structuré destination TD
        TD.DataBodyRange(1, 1).Resize(K, TS.ListColumns.Count) = Application.Transpose(TL) 'renvoie le tableau TL transposé dans les données de TD
    End If 'fin de la condition
    K = 0: Erase TL 'réinitialise K et efface le tableau TL
Next O 'prochain onglet de la boucle 1
CS.Close False 'ferme le classeur source sans enregistrer
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub
Le 05/05/2022 à 15:31

Ca marche nickel, Merci à tous !!

Rechercher des sujets similaires à "import donnees fichier"