XL 2021 import-informations-classeurs-fermes

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Bonsoir à toues et à tous,
Je vous souhaite une belle fin de journée :)

Il y a déjà longtemps, mon cher job75 m'avait fait un code que j'avais "un peu" modifié pour l'adapter exactement au besoin de mon fichier de travail.
Il fonctionne parfaitement :
VB:
Option Explicit

Sub Import()
Dim t#, chemin$, fichier$, feuille$, ncol%, dest As Range, form$, h As Variant, n&
t = Timer
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "fichier*.xlsm") '1er fichier du dossier
If fichier = "" Then MsgBox "Aucun fichier de facturation trouvé..."
feuille = "RdV_transfert"
ncol = 11 'nombre de colonnes à copier dans la feuille source (A:Z)
Set dest = Sheets("RdV_transfert").[A1] '1ère cellule du tableau, à adapter
Application.ScreenUpdating = False
If dest.Parent.FilterMode Then dest.Parent.ShowAllData 'si la feuille est filtrée
While fichier <> ""
    form = "'" & chemin & "[" & fichier & "]" & feuille & "'!"
    h = ExecuteExcel4Macro("MATCH(9^9," & form & "A1)") 'recherche du dernier nombre
    If IsNumeric(h) Then
        If h > 3 Then 'à partir de la ligne 4
            With dest(2, 2).Offset(n).Resize(h - 3, ncol)
                .Columns(0) = fichier 'colonne A supplémentaire
                .FormulaArray = "=TRIM(" & form & "R4C1:R" & h & "C" & ncol & ")" 'formule de liaison matricielle
                .Value = .Value 'supprime les formules
            End With
            n = n + h - 3
        End If
    End If
    fichier = Dir 'fichier suivant
Wend
'---mise en forme---
If n Then
    With dest(2).Resize(n, ncol + 1)
        .Borders.Weight = xlHairline
        .BorderAround Weight:=xlThin 'pourtour
    End With
End If
dest(2).Offset(n).Resize(Rows.Count - n - dest.Row, ncol + 1).Delete xlUp 'RAZ en dessous
'dest.Parent.Columns.AutoFit 'ajustement largeurs
With dest.Parent.UsedRange: End With 'actualise la barre de défilement verticale
Application.ScreenUpdating = True
MsgBox "Durée " & Format(Timer - t, "0.00 \s"), , "RdV_transfert"
End Sub

Aujourd'hui, j'ai besoin de l'utiliser pour un autre besoin que je décris ci-dessous :
Importer à partir des classeurs (classeurs sources)
fichier_Charlotte : onglet RdV_transfert
fichier_Lionel : onglet RdV_transfert
de A2 à K2 jusqu'à dernière ligne NON vide
si C2 = date (aujourdhui()) et si écart de jours entre B2 et C2 est > à 3
Important : B2 et C2 ne sont pas au même format (pour le calcul de l'écart)
..........Sinon, ne pas importer

Classeur cible

SMS_jour test : onglet RdV_transfert

Tous les onglets "RdV_transfert " des fichiers sont identiques

Voilà plusieurs jours que je tente de l'adapter mais je n'y arrive pas car le niveau de technicité du code ne me permets pas de le comprendre.

Pourriez-vous m'aider ?
En cas, je joins les fichiers et je continue d'essayer
Avec mes remerciements,
Amicalement,
lionel :)
 

Pièces jointes

  • SMS_jour test.xlsm
    37 KB · Affichages: 12
  • fichier_Charlotte.xlsm
    32.5 KB · Affichages: 9
  • fichier_lionel.xlsm
    32.6 KB · Affichages: 10
Dernière édition:

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Re-Gérard,
Sauf erreur de fil car il y en a eu plusieurs, c'est celui-là :
Je transferts dans ce fil.
lionel :)
 

patricktoulon

XLDnaute Barbatruc
@Usine à gaz
oui on peut les ouvrir comme ça là il n'y a pas de problèmes
mais en ouverture par autre macro4, formule de liaison , adobd.connection c'est pas possible
donc soit ils sont bloqué en lecture seule
soit ils sont nazes

c'est pas compliqué;)
j'ai testé plusieurs fois
ou alors incompatibilité avec 2013 chez moi

mais une formule de liaison me semble t il n'a pas changé de syntaxe entre 2013 et ta version excel (du moins je crois pas)

même ma fonction perso pour chopper la dernière ligne utilisée dans un fichier fermé me donne une donnée erronée et le dialog

regarde
des que je valide la formule la boite de dialog s'ouvre et je suis obligé de rechoisir charlotte pour que la donnée soir récupérée
pourtant la formule est bonne dès le départ
demo.gif
 

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Re Patrick,
Gérard m'a répondu et m'a demandé de transférer ma demande dans le fil d'origine :
C'est aussi ce que j'ai fait :)
 

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
@Usine à gaz
oui on peut les ouvrir comme ça là il n'y a pas de problèmes
mais en ouverture par autre macro4, formule de liaison , adobd.connection c'est pas possible
donc soit ils sont bloqué en lecture seule
soit ils sont nazes

c'est pas compliqué;)
j'ai testé plusieurs fois
ou alors incompatibilité avec 2013 chez moi

mais une formule de liaison me semble t il n'a pas changé de syntaxe entre 2013 et ta version excel (du moins je crois pas)

même ma fonction perso pour chopper la dernière ligne utilisée dans un fichier fermé me donne une donnée erronée et le dialog

regarde
des que je valide la formule la boite de dialog s'ouvre et je suis obligé de rechoisir charlotte pour que la donnée soir récupérée
pourtant la formule est bonne dès le départ
Regarde la pièce jointe 1129099
OUI, quand je fais comme ça la liaison est bonne :)
 

laurent950

XLDnaute Accro
Bonjour @Usine à gaz , @patricktoulon, @job75 , @Marcel32

J'ai pas compris la condition a Lionel, donc j'ai fait le code avec une autre condition.

Comme je ne comprend pas ta condition :
dans ton fichier "charlotte.xlsm" et "Lionel.xlsm"
Je vais te copier toute les lignes qui correspondent a la date du 26/01/2022
dans le fichier "SMS_jour test.xlsm" Feuille "RdV_transfert" à partir de la cellule A2

Une fois la condition comprise le code est réalisé ci-dessous en Poste #1 ??
si C2 = date (aujourd'hui()) et si écart de jours entre B2 et C2 est > à 3 alors

Lire et copier dans les classeurs Excel fermés puis transfert dans le nouveau classeur

VB:
Option Explicit
Sub RequeteClasseurFermeLionel()
' Le classeur qui établie la connexion
Dim Wkb As Workbook, Wks As Worksheet
    Set Wkb = ThisWorkbook
    Set Wks = Wkb.Worksheets("RdV_transfert")
' Les Fichiers "fichier*.xlsm" (les Base de données "Feuille RdV_transfert")
Dim chemin As String
Dim Fich As String
    chemin = ThisWorkbook.Path & "\"
    Fich = Dir(chemin & "fichier*.xlsm") ' 1er fichier du dossier
    If Fich = "" Then MsgBox "Aucun fichier de facturation trouvé...": Exit Sub
' Date (Pour la ou les condition)
Dim date1 As Date ' La date D'aujourd'hui
Dim date2 As Date ' La Date en B2
Dim date3 As Date ' La Date en C2
Dim dif As Long   ' L'ecart entre deux date

' Sauf les entêtes (zone a modifier en fonction des besoin)
Wks.Range("A2:AG65536").ClearContents

' Boucle
    While Fich <> ""
'   Les connecteurs
    Dim Cn As ADODB.Connection  ' La Connection
    Dim Rst  As ADODB.Recordset ' La Recordset
    Dim TDon() As Variant       ' Pour la récupération du Recordset dans une variable tableau de type Variant
    Dim TRes() As Variant       ' Pour récupérer le résultat de la requête à Lionel
    Dim i As Long, j As Long
    Dim Fichier As String
    Dim NomFeuille As String    ' Le nom de la feuille (dans le classeur source qui est la base de donnée "RdV_transfert"
    Dim texte_SQL As String     ' La requête (Pour récupérer la table du classeur excel Fermé soit la Feuille "RdV_transfert"
    ' Chemin complet du classeur fermé (servant de base de données)
        Fichier = chemin & Fich ' Chemin complet du classeur fermé qui contient la base de donnée.
    'Nom de la feuille dans le classeur fermé
        NomFeuille = CStr(Wks.Name) ' Soit l'onglet du classeur fermé qui contient la base de donnée (La table) "RdV_transfert"
    '--- Connection ---
            '--- Connection ---
    Set Cn = New ADODB.Connection
    With Cn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
                                        & Fichier & ";Extended Properties=""Excel 12.0;HDR=YES;"""
        .Open
    End With
    '-----------------
    'Définit la requête.
    '/!\ Attention à ne pas oublier le symbole $ après le nom de la feuille.
    texte_SQL = "SELECT * FROM [" & NomFeuille & "$]"
    '-----------------
    Set Rst = New ADODB.Recordset
    Set Rst = Cn.Execute(texte_SQL)
        
    'Exemple 1: Ecrit le résultat de la requête "Rst" dans la cellule (Ici A2 pour Exemple)
    'Range("A18").CopyFromRecordset Rst
        
    'Exemple 2 :  Ecrit le résultat de la requête "Rst" dans la variable tableau TDon
     TDon = Rst.GetRows
    ' Option : Pour récupérer les entêtes (Non Prise ici)
    '          Si il y a des requête complexe solution de contournement (ci-dessous)
    '          Redimension du tableau et récupération de l'entête dans ce tableau
    'nrow = UBound(TDon, 1) - 1
    'ncol = UBound(TDon, 2) + 1
    'ReDim Preserve TDon(nrow + 1, ncol)
        'For i = 0 To nrow
            'TDon(i, ncol) = Rst.Fields(i).Name
        'Next
            
'    ' La condition @Usineagaz
'    ' la condition : que je comprend pas
'    ' ' si C2 = date (aujourdhui()) ET si écart de jours entre B2 et C2 est > à 3

'    ' Exemple pour copier directement de la variable TDon vers la feuille Excel

'        For i = LBound(TDon, 2) To UBound(TDon, 2)
'            date1 = Format(Now, "dd/mm/yyyy")
'            date2 = TDon(2, i)
'            date3 = Format(TDon(1, i), "dd/mm/yyyy")
'            dif = date3 - date2
'            x = Wks.Cells(65536, 1).End(xlUp).Row + 1
'                'If date1 = date2 And dif > 3 Then
'                    For j = LBound(TDon, 1) To UBound(TDon, 1)
'                        Wks.Cells(x, j + 1) = TDon(j, i)
'                    Next j
'                'End If
'            Next i

    ' la condition : alors je vais copier toute les lignes du fichier Charlotte et lionel (en C2 = 26/01/2022)
    
    '    ' Exemple pour copier directement de la variable tableau TDon (dans une variable tableau TRes) puis la feuille Excel
    
            ReDim TRes(LBound(TDon, 1) + 1 To UBound(TDon, 1) + 1, 1 To 1)
            For i = LBound(TDon, 2) To UBound(TDon, 2)
            date2 = TDon(2, i)
            If date2 = "26/01/2022" Then
                For j = LBound(TDon, 1) To UBound(TDon, 1)
                    TRes(j + 1, i + 1) = TDon(j, i)
                Next j
                ReDim Preserve TRes(LBound(TRes, 1) To UBound(TRes, 1), 1 To UBound(TRes, 2) + 1)
            End If
            Next i
            ReDim Preserve TRes(LBound(TRes, 1) To UBound(TRes, 1), 1 To UBound(TRes, 2) - 1)
            
            ' Option 1 :Resultat avec Application.Transpose(TRes)
                'Wks.Cells(Wks.Cells(65536, 1).End(xlUp).Row + 1, 1).Resize(UBound(TRes, 2), UBound(TRes, 1)) = Application.Transpose(TRes)
            
            ' Option 2 : Resultat avec avec conversion (Tableau de grande capacité)
                i = Empty: j = Empty: Erase TDon
                ReDim TDon(LBound(TRes, 2) To UBound(TRes, 2), LBound(TRes, 1) To UBound(TRes, 1))
                    For i = LBound(TRes, 2) To UBound(TRes, 2)
                        For j = LBound(TRes, 1) To UBound(TRes, 1)
                            TDon(i, j) = TRes(j, i)
                        Next j
                    Next i
                Wks.Cells(Wks.Cells(65536, 1).End(xlUp).Row + 1, 1).Resize(UBound(TDon, 1), UBound(TDon, 2)) = TDon
    
    '--- Fermeture connexion ---
    Rst.Close
    Set Rst = Nothing
    Set Cn = Nothing
    Erase TRes: Erase TDon
    i = Empty: j = Empty
    Fich = Dir()
    Wend
End Sub

Laurent
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
re
Je viens de tester mais ça beug ici " Dim Cn As ADODB.Connection ' La Connection"
il faut activer la référence en early binding !!!!!!!!!!!
quand a moi j'ai tout repris tes deux fichier et sauvé chez moi




et dans un classeur vierge dans le même dossier que les deux autres
avec une feuille"Feuil1"
VB:
Sub test()
'patricktoulon
    Dim chemin$, Fichier$, Rng As Range, Feuille$, AddR$, mesFichiers, derlig&
    
    chemin$ = ThisWorkbook.Path & "\"
    mesFichiers = Array("fichier_lionel.xlsm", "fichier_Charlotte.xlsm")    'array de noms de fichier (peut etre remplacer par un dialog multi select)
    
    For i = LBound(mesFichiers) To UBound(mesFichiers)
        DoEvents
        Fichier$ = mesFichiers(i)    ' fichier qui va etre repéché
        Set Rng = [A2:k1000]    ' range qui va etre examiné dans le fichier fermer
        Feuille = "RdV_transfert"    ' détermine la feuille dans le fichier fermé
        
        'détermine la derniere ligne utilisé en [a:A] du fichier fermé(fonction perso(voir en bas)
        derligclosedfich = GetLastRowColInClosedFich(chemin, Fichier, Feuille, Rng.Columns(1).EntireColumn)

        derlig = Feuil1.[A1:A10000].End(xlUp).Row + 1    'derniere ligne utilisée +1 dans le fichier destination(doit s'actualiser a chaque tour de boucle )

        '****************************************************************
        'methode ligne par ligne
        'a = 2
        'For x = derlig To derlig + derligclosedfich - 1
        'Cells(x, 1).Resize(, 10).Formula = "='" & chemin & "[" & Fichier & "]" & Feuille & "'!" & Cells(a, 1).Resize(, 10).Address
        'a = a + 1

        'Next
        'Feuil1.Cells(x, 1).Resize(, 10).Value = Feuil1.Cells(x, 1).Resize(, 10)
        '***************************************************************

        ' OU

        '***************************************************************
        'methode toute la plage d'un coup (formule matricielle "formulaArray")
        AddR = [A2].Resize(derligclosedfich - 1, 10).Address    ' address de la plage complete des fichiers fermés

        '********************************************************
        'partie de code provisoire a supprimer c'est juste pour voir
        MsgBox " plage du fichier " & Fichier & " à copier =" & AddR & vbCrLf & "destination = " & "A" & derlig
        '********************************************************


        With Feuil1.Cells(derlig, 1).Resize(derligclosedfich - 1, 10)
            'incription de la formule matricielle dans toute la plage de meme dimension que la plage utilisée dans le fichier fermé
            .FormulaArray = "='" & chemin & "[" & Fichier & "]" & Feuille & "'!" & AddR
            .Value = .Value    'suppression de la formule par les valeurs
        End With
        '***************************************************************

    Next
End Sub

Function GetLastRowColInClosedFich(chemin$, Fichier$, Feuille, Rng As Range)
'fonction pour chopper la dernière ligne utilisée  dans une colonne d'un fichier fermer
'auteur:patricktoulon
    Dim AddR$, Formule, n&
    AddR = Rng.Address(, , xlR1C1)
    Formule = "'" & chemin & "[" & Fichier & "]" & Feuille & "'!" & AddR
    On Error Resume Next
    n = ExecuteExcel4Macro("MATCH(""zzz""," & Formule & ")")    'dernière cellule texte en colonne de la rng 
    On Error GoTo 0
    GetLastRowColInClosedFich = n
End Function

à tester
ps: tu n'a pas de librairie à gérer

je salut laurent au passage ;)
 

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
re

il faut activer la référence en early binding !!!!!!!!!!!
quand a moi j'ai tout repris tes deux fichier et sauvé chez moi




et dans un classeur vierge dans le même dossier que les deux autres
avec une feuille"Feuil1"
VB:
Sub test()
'patricktoulon
    Dim chemin$, Fichier$, Rng As Range, Feuille$, AddR$, mesFichiers, derlig&
  
    chemin$ = ThisWorkbook.Path & "\"
    mesFichiers = Array("fichier_lionel.xlsm", "fichier_Charlotte.xlsm")    'array de noms de fichier (peut etre remplacer par un dialog multi select)
  
    For i = LBound(mesFichiers) To UBound(mesFichiers)
        DoEvents
        Fichier$ = mesFichiers(i)    ' fichier qui va etre repéché
        Set Rng = [A2:k1000]    ' range qui va etre examiné dans le fichier fermer
        Feuille = "RdV_transfert"    ' détermine la feuille dans le fichier fermé
      
        'détermine la derniere ligne utilisé en [a:A] du fichier fermé(fonction perso(voir en bas)
        derligclosedfich = GetLastRowColInClosedFich(chemin, Fichier, Feuille, Rng.Columns(1).EntireColumn)

        derlig = Feuil1.[A1:A10000].End(xlUp).Row + 1    'derniere ligne utilisée +1 dans le fichier destination(doit s'actualiser a chaque tour de boucle )

        '****************************************************************
        'methode ligne par ligne
        'a = 2
        'For x = derlig To derlig + derligclosedfich - 1
        'Cells(x, 1).Resize(, 10).Formula = "='" & chemin & "[" & Fichier & "]" & Feuille & "'!" & Cells(a, 1).Resize(, 10).Address
        'a = a + 1

        'Next
        'Feuil1.Cells(x, 1).Resize(, 10).Value = Feuil1.Cells(x, 1).Resize(, 10)
        '***************************************************************

        ' OU

        '***************************************************************
        'methode toute la plage d'un coup (formule matricielle "formulaArray")
        AddR = [A2].Resize(derligclosedfich - 1, 10).Address    ' address de la plage complete des fichiers fermés

        '********************************************************
        'partie de code provisoire a supprimer c'est juste pour voir
        MsgBox " plage du fichier " & Fichier & " à copier =" & AddR & vbCrLf & "destination = " & "A" & derlig
        '********************************************************


        With Feuil1.Cells(derlig, 1).Resize(derligclosedfich - 1, 10)
            'incription de la formule matricielle dans toute la plage de meme dimension que la plage utilisée dans le fichier fermé
            .FormulaArray = "='" & chemin & "[" & Fichier & "]" & Feuille & "'!" & AddR
            .Value = .Value    'suppression de la formule par les valeurs
        End With
        '***************************************************************

    Next
End Sub

Function GetLastRowColInClosedFich(chemin$, Fichier$, Feuille, Rng As Range)
'fonction pour chopper la dernière ligne utilisée  dans une colonne d'un fichier fermer
'auteur:patricktoulon
    Dim AddR$, Formule, n&
    AddR = Rng.Address(, , xlR1C1)
    Formule = "'" & chemin & "[" & Fichier & "]" & Feuille & "'!" & AddR
    On Error Resume Next
    n = ExecuteExcel4Macro("MATCH(""zzz""," & Formule & ")")    'dernière cellule texte en colonne de la rng
    On Error GoTo 0
    GetLastRowColInClosedFich = n
End Function

à tester
ps: tu n'a pas de librairie à gérer

je salut laurent au passage ;)
Hello Patrick pour ce boulot.
"il faut activer la référence en early binding !!!!!!!!!!!"
Pas trouvée !!!

j'ai testé : ça ne beugue pas mais ça n'importe pas lol :)
 

patricktoulon

XLDnaute Barbatruc
pour le model de laurent avec ado
c'est la dataobject(x).library machin chose


dans mon exemple
et non chez moi ca fonction
y a pas de restitution c'est carément des liaison remplacé par les valeur par la suite
chez moi les deux méthode fonctionnent sauf que laurent lui tri les dates pas moi le tri on peut le faire apres
 

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
pour le model de laurent avec ado
c'est la dataobject(x).library machin chose


dans mon exemple
et non chez moi ca fonction
y a pas de restitution c'est carément des liaison remplacé par les valeur par la suite
chez moi les deux méthode fonctionnent sauf que laurent lui tri les dates pas moi le tri on peut le faire apres
Pour Laurent :
c'est la dataobject(x).library machin chose = je l'ai activé

Pour ton code : j' l'ai copié tel quel et ... pas de restitution :)
Je vais encore regardé mais ce n'est qu'un copier/coller :)
 

job75

XLDnaute Barbatruc
Bon ce n'était pas très difficile à adapter, voici la bonne macro :
VB:
Sub Import()
Dim t#, chemin$, fichier$, feuille$, ncol%, dest As Range, form$, h As Variant, n&
t = Timer
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "fichier*.xlsm") '1er fichier du dossier
If fichier = "" Then MsgBox "Aucun fichier de facturation trouvé..."
feuille = "RdV_transfert"
ncol = 11 'nombre de colonnes à copier dans la feuille source (A:K)
Set dest = Sheets("RdV_transfert").[A1] '1ère cellule du tableau, à adapter
Application.ScreenUpdating = False
If dest.Parent.FilterMode Then dest.Parent.ShowAllData 'si la feuille est filtrée
While fichier <> ""
    form = "'" & chemin & "[" & fichier & "]" & feuille & "'!"
    h = ExecuteExcel4Macro("MATCH(""zzz""," & form & "C1)") 'recherche du dernier texte en colonne 1
    If IsNumeric(h) Then
        If h > 1 Then 'à partir de la ligne 2
            With dest(2).Offset(n).Resize(h - 1, ncol)
                .Columns(ncol + 1) = fichier 'colonne L supplémentaire
                .FormulaArray = "=TRIM(" & form & "R2C1:R" & h & "C" & ncol & ")" 'formule de liaison matricielle
                .Value = .Value 'supprime les formules
            End With
            n = n + h - 1
        End If
    End If
    fichier = Dir 'fichier suivant
Wend
'---mise en forme---
If n Then
    With dest(2).Resize(n, ncol + 1)
        .Borders.Weight = xlHairline
        .BorderAround Weight:=xlThin 'pourtour
    End With
End If
dest(2).Offset(n).Resize(Rows.Count - n - dest.Row, ncol + 1).Delete xlUp 'RAZ en dessous
'dest.Parent.Columns.AutoFit 'ajustement largeurs
With dest.Parent.UsedRange: End With 'actualise la barre de défilement verticale
Application.ScreenUpdating = True
MsgBox "Durée " & Format(Timer - t, "0.00 \s"), , "RdV_transfert"
End Sub
Les fichiers joints doivent bien sûr être téléchargés dans le même dossier (le bureau).
 

Pièces jointes

  • SMS_jour test(1).xlsm
    37.7 KB · Affichages: 3
  • fichier_Charlotte.xlsm
    32.5 KB · Affichages: 3
  • fichier_lionel.xlsm
    32.6 KB · Affichages: 3

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Bonsoir gérard :)
Comme d'hab c'est nickel :)

"Bon ce n'était pas très difficile à adapter"
Pour qui ? lol

Le fichier de travail qui va recevoir les importations est "occupé" à partir de la colonne "L", je n'ai pas vu comment supprimer l'importation : "fichier_Charlotte.xlsm" de la colonne L mais je cherche lol

Maintenant, ça se corse lol :
Est-il possible d'inclure 2 conditions :
Dans les fichiers sources

si B2 = date (aujourdhui()) et si écart de jours entre B2 et C2 (date d'Appel) est > à 3 = importer
Important : B2 et C2 ne sont pas au même format (pour le calcul de l'écart)

Sinon, ne pas importer

Merci gérard, encore et encore
lionel :)
 

Discussions similaires