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:

laurent950

XLDnaute Accro
Re

Pour @Usine à gaz

avec la condition
'date1 = Format(Now, "dd/mm/yyyy")
'date2 = TDon(2, i)
'date3 = Format(TDon(1, i), "dd/mm/yyyy")
If (date2 = date1 And (date3 - date2) > 3) Or (date2 = date1 And (date2 - date3) > 3) Then

+ une gestion d'erreur si aucune date trouvé
+ Application.Transpose (Remplacer par une Boucle)

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 resultat de la requêtte à 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
  
            ReDim TRes(LBound(TDon, 1) + 1 To UBound(TDon, 1) + 1, 1 To 1)
            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")
            If (date2 = date1 And (date3 - date2) > 3) Or (date2 = date1 And (date2 - date3) > 3) Then
                For j = LBound(TDon, 1) To UBound(TDon, 1)
                    TRes(j + 1, UBound(TRes, 2)) = 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
          
            On Error Resume Next
            ReDim Preserve TRes(LBound(TRes, 1) To UBound(TRes, 1), 1 To UBound(TRes, 2) - 1)
            If Err = 0 Then
            ' 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
            End If
            On Error GoTo 0
  
    '--- Fermeture connexion ---
    Rst.Close
    Set Rst = Nothing
    Set Cn = Nothing
    Erase TRes: Erase TDon
    i = Empty: j = Empty
    Fich = Dir()
    Wend
End Sub
 

job75

XLDnaute Barbatruc
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
Il vaut mieux tout importer et ensuite supprimer les lignes indésirables du tableau importé :
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
dest(2).Resize(Rows.Count - dest.Row, ncol).Delete xlUp 'RAZ
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)
                .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
'---supprime les lignes dont les dates ne conviennent pas---
If n Then
    dest(1, ncol + 1).EntireColumn.Insert 'insère une colonne auxiliaire
    With dest(2, ncol + 1).Resize(n) 'en colonne L
        .Formula = "=1/AND(C2=TODAY(),SUBSTITUTE(SUBSTITUTE(B2,"" "",""/"",1),"" "",""/"",1)-C2>3)" 'critère de filtrage
        .Value = .Value 'supprime les formules
        .EntireRow.Sort .Cells, xlAscending, Header:=xlNo 'tri pour regrouper et accélérer
        On Error Resume Next 'si aucune SpecialCell
        .SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete 'supprime les valeurs d'erreur
        On Error Resume Next
    End With
    dest(1, ncol + 1).EntireColumn.Delete 'supprime la colonne auxiliaire
End If
n = dest.Parent.UsedRange.Rows.Count - 1
'---mise en forme---
If n Then
    With dest(2).Resize(n, ncol)
        .Borders.Weight = xlHairline
        .BorderAround Weight:=xlThin 'pourtour
    End With
End If
'dest.Parent.Columns.AutoFit 'ajustement largeurs
Application.ScreenUpdating = True
MsgBox "Durée " & Format(Timer - t, "0.00 \s"), , "RdV_transfert"
End Sub
J'ai modifié une date dans fichier_Charlotte.xlsm pour qu'il y ait au moins une ligne conservée.
 

Pièces jointes

  • SMS_jour test(2).xlsm
    40.2 KB · Affichages: 3
  • fichier_Charlotte.xlsm
    32.5 KB · Affichages: 3

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Merci Gérard pour ce nouveau code.

Le code importe une ligne :
RdV 24 01 02 2022 09:00 29 01 22 OK agenda Réseau 24 Nom 8 33111111126 Nom Réseau 24 490000022 lionel 700000023

Mais cette ligne n'aurait pas du être importée.
--------------------------------------------------------------
J'ai certainement dû encore mal formuler ma demande :
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
------------------------------------------------------------
Donc, pour cette ligne
B2 correspond à 01 02 2022 09:00 (date du RdV) et n'est pas égal à aujourd'hui et C2 correspond à 29 01 22 (Date de l'appel)

Pour qu'elle soit importée il faudrait qu'elle soit comme ce qui suit :
RdV 24 29 01 2022 09:00 25 01 22 OK agenda Réseau 24 Nom 8 33111111126 Nom Réseau 24 490000022 lionel 700000023
"29 01 2022 09:00" étant = à aujourd'hui et 25 01 22 étant inférieur de + de 3 jours à B2

Exemples de résultat à obtenir :
Lignes dans les fichier sources
2 exemples (j'aurais certainement du commencer par ça) :
ligne à importer
RdV 1729 01 2022 14:3025 01 22OK agendaRéseau 17Nom 133111111119Nom Réseau 17490000015Charlotte700000016
Car 29 01 2022 14:30 (col B date du RdV) est égal à aujourd'hui et 25 01 22 (col C date appel) est inférieur de 4 jours (soit < de plus de3) à B2.

lignes à ne pas importer

RdV 1931 01 2022 15:0026 01 22OK agendaRéseau 19Nom 333111111121Nom Réseau 19490000017Charlotte700000018
Car 31 01 2022 15:00 est différent de aujourd'hui
et
RdV 2029 01 2022 14:3026 01 22OK agendaRéseau 20Nom 433111111122Nom Réseau 20490000018Charlotte700000019
29 01 2022 14:30 est égal à aujourd'hui mais 26 01 22 à un écart avec B2 de 3 donc pas > ) 3

Désolé de n'avoir pas été très clair une fois de plus :)
lionel :)
 
Dernière édition:

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Bsr Gérard,
C'est vrai mais je m'étais mélangé "les pinceaux" désolé :rolleyes:
C'est comme ça ce que j'ai besoin :
ligne à importer
RdV 1729 01 2022 14:3025 01 22OK agendaRéseau 17Nom 133111111119Nom Réseau 17490000015Charlotte700000016
Car 29 01 2022 14:30 (col B date du RdV) est égal à aujourd'hui et 25 01 22 (col C date appel) est inférieur de 4 jours (soit < de plus de3) à B2.

lignes à ne pas importer

RdV 1931 01 2022 15:0026 01 22OK agendaRéseau 19Nom 333111111121Nom Réseau 19490000017Charlotte700000018
Car 31 01 2022 15:00 est différent de aujourd'hui
et
RdV 2029 01 2022 14:3026 01 22OK agendaRéseau 20Nom 433111111122Nom Réseau 20490000018Charlotte700000019
29 01 2022 14:30 est égal à aujourd'hui mais 26 01 22 à un écart avec B2 de 3 donc pas > ) 3

Encore désolé :)
 

job75

XLDnaute Barbatruc
Bon si tu veux que la date de B2=AUJOURDHUI() prends ce fichier (3) avec :
VB:
.Formula = "=1/AND(INT(--SUBSTITUTE(SUBSTITUTE(B2,"" "",""/"",1),"" "",""/"",1))=TODAY(),TODAY()-C2>3)" 'critère de filtrage
 

Pièces jointes

  • SMS_jour test(3).xlsm
    40.4 KB · Affichages: 8
  • fichier_Charlotte.xlsm
    32.5 KB · Affichages: 3

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Bonjour Gérard,
Bonjour Laurent,
Bonjour Patrick,
Bonjour Marcel,
Bonjour le Forum,

Ce fil a été résolu par Gérard, par Laurent, et presque par Patrick lol,
Voilà donc 3 codes différents avec lesquels, en les croisant, je comprends mieux leurs écritures.

Encore un bel exemple de solidarité et je vous en remercie vivement.
Dieu et vous savent combien je suis compliqué et ch...t lol 😇

J'aurais p'être dû commencer par le pourquoi de mon besoin.
Nous prenons des RdVs téléphoniques pour des Clients.
Il arrive souvent que les personnes avec qui nous prenons les RdVs oublient si les RdVs ont été pris + de 3 jours avant.
C'est pour cela que je souhaite envoyer des sms, le jour des RdVs, aux gens qui ont un RdV pris + de 3 jours avant.
D'où importation dans un fichier (SMS_jour) des lignes (cellules A à K) des RdVs du jour pris + de 3 jours avant.

Voilà pourquoi c'est très important pour moi !

Encore une très très grand MERCI à vous
lionel :)
 
Dernière édition:

Discussions similaires