XL 2013 Extraction de valeurs dans un classeur fermé

ALEX1995

XLDnaute Nouveau
Bonjour à tous,

Je suis à mes début en programmation VBA et il y a beaucoup de choses qui m'échappe encore.

Je souhaite créer un programme VBA qui à l'aide d'une liste de cellule en colonne A sur l'onglet A du classeur A irait chercher dans un classeur B, dans la feuille B, les cellules décalées de deux vers la droite et d'un vers le bas des cellules qui sont égales à la liste de cellule du classeur A, feuille A et colonne A.

Ma demande n'est peut être pas très clair, je vous transmet deux fichier qui illustreraient mieux mes propos.
 

Fichiers joints

Robert

XLDnaute Barbatruc
Bonjour Alex, bonjour le forum,

Ce n'est pas vraiment du "Classeur Fermé", c'est du "j'ouvre, je traite et je referme"...
Si les deux classeurs se trouvent dans le même dossier le code ci-dessous devrait convenir, sinon il faudra adapter... Code à mettre dans le classeur A :

VB:
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 CA As String 'déclare la variable CA (Chemin d'Accès)
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 I As Integer 'déclare la variable I (Incrément)
Dim R As Range 'déclare la variable R (Recheche)

Application.ScreenUpdating = False 'masque les rafrîchissements d'écran
Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets("A") 'définit l'onglet destination OD
CA = CD.Path & "\" 'définit le chemin d'accès CA
TV = OD.Range("A1").CurrentRegion 'définit la tableau des valeurs TV
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set CS = Workbooks("B.xlsx") 'définit le classeur source (génère une erreur si le classeur n'est pas ouvert)
If Err <> 0 Then 'condition : si une erreur a été générée
    Err.Clear 'supprime l'erreur
    Set CS = Workbooks.Open(CA & "B.xlsx") 'définit la classeur source CS en l'ouvrant
End If 'fin de la condition
On Error GoTo 0 'annule la gestion des erreurs
Set OS = CS.Worksheets("B") 'définit l'onglet source OS
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs (en partant de la seconde)
    Set R = OS.Cells.Find(TV(I, 1), , xlValues, xlWhole) 'définit la recherche R (Recheche dans l'onglet source la valeur entière de la donnée ligne I colonne 1 du tableau des valeurs TV)
    If Not R Is Nothing Then 'condition : s'il existe au moins une occurrence trouvée
        OD.Cells(I, "B").Value = CDate(R.Offset(1, 2)) 'renvoie dans la cellule ligne I colonne B de l'onglet OD la date d'arrivée de la première occurrence trouvée
        OD.Cells(I, "C").Value = CDate(R.Offset(1, 3)) 'renvoie dans la cellule ligne I colonne C de l'onglet OD la date de départ de la première occurrence trouvée
    End If 'fin de la condition
    Set R = Nothing 'vide la variable R
Next I 'prochaine ligne de la boucle
CS.Close False 'ferme le classeur source sans enregistrer
Application.ScreenUpdating = True 'affiche les rafrîchissements d'écran
End Sub
 

ALEX1995

XLDnaute Nouveau
Merci beaucoup Robert, c'est exactement ce que je voulais.

Dans la même idée je souhaiterai faire davantage de manip avec ce fichier dans le but d'utiliser une base de données afin de remplir des onglets.

Je m'explique, j'ai une liste de nom de navire avec la date d'arrivée et de fin des interventions ainsi qu'un numéros d'affaire.
Je souhaiterais:
Etape1 --> créer un onglet correspondant à chaque bateau de la liste "nom" à condition que la date de fin ne soit pas dépassée de +7jours.
Etape 2 --> Remplir les onglets des bateaux à l'aide d'une base de données (onglet "base" du classeur "B1"). C'est a dire que lorsque je rentre sur l'onglet du navire "alixel" par exemple je retrouve toutes les lignes correspondant à l'affaire "ARVA6061"
Etape 3 -->La base de données sera modifiée plusieurs fois par jours et ce serait bien que les onglets soient actualiser lorsque je lance une macro "actualiser" par exemple. Lorsque le fichier est actualisé ce serait bien également que les onglets des navires dont la date de fin est dépassé de + de 7 jours soient supprimées en même temps.

ce n'est pas évident d'être clair, j’espère l'avoir été suffisamment. ci-joint le fichier source et le fichier qui contient la base de données.

J'espère que quelqu'un pourra m'aider...
 

Fichiers joints

Robert

XLDnaute Barbatruc
Re,

Etape 2 --> Remplir les onglets des bateaux à l'aide d'une base de données (onglet "base" du classeur "B1"). C'est a dire que lorsque je rentre sur l'onglet du navire "alixel" par exemple je retrouve toutes les lignes correspondant à l'affaire "ARVA6061"
Rien compris ! il sort d'où Alixel ?!...
 

ALEX1995

XLDnaute Nouveau
Ah ok! je suis désolé.

Dans un classeur A1 j'ai une liste navire en colonne A, la date d'arriver et de départ en colonne B et C et enfin en colonne D un numéros de bateau. Exemple: colonne A (nom du bateau) : Alixel? colonne B (date d'arrivée): 05/04/2018, colonne C (date de fin): 25/07/2019 et en colonne D (numeros du bateau): ARVA6061

Dans un classeur B1 j'ai ma base de données avec un numéro de bateau (colonne A) à chacune des lignes. ce classeur est mis à jours plusieurs fois par jours.
1564393991386.png

Dans le classeur A1, les 4 colonne(nom du bateau, date d'arrivée, date de fin et numéro de bateau) seront rempli en amont.
J'aimerais tout d'abord créer un onglet par nom de bateau (suivant la colonne A). Par contre le rajout des onglets est réalisé suivant 2 conditions :
-L'onglet n'existe pas
-et si la date de fin (colonne C) n'est pas dépassé de la date en cours de plus de 7 jours

Ensuite j'aimerais que les onglets créés soient remplis automatiquement suivant le numéro du bateau. C'est à dire que lorsque l'on lance la macro, chaque onglets (qui représentent chacun un bateau) se rempli avec les lignes correspondantes aux différents numéros de bateau (classeur A1, onglet A, colonne D) de la base de données.
Exemple: L'onglet ALIXEL (cellule A2 du classeur A1) a été créé, le remplissage de l'onglet se fait en copiant toutes les lignes où la cellule de la colonne A correspond au numéros de bateau "ARVA6061" (cellule D2, classeur A1).
Numéro bateauAffaire de regroupementposte libellé 1date de clotureSiteNom de l'affaire
ARVA6061ARVA6061502150INTERVENTION CHEF D'EQUIPE
1​
1​
ARVA6061ARVA6061R00001REPRISE DE SOUDURE SUR ETRAVE
1​
1​

Et enfin j'aimerais que chaque onglet puisse être mis à jours en cliquant sur un bouton par exemple.

J'espère avoir été plus clair,

Alex
 

Fichiers joints

Robert

XLDnaute Barbatruc
Re

Essaie comme ça (code à placer dans le classeur A1.xlms :

VB:
Sub Macro1()
[COLOR=rgb(40, 50, 78)]Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OA As Worksheet 'déclare la variable OA (Onglet A)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim TD As Variant 'déclare la variable TD (Tableau Destination)
Dim TS As Variant 'déclare la variable TS (Tableau Source)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim L As Byte 'déclare la variable L (incrément)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
Dim LI As Integer 'déclare la variable LI (Ligne)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CD = ThisWorkbook 'définit le classeru destination CD
CA = CD.Path & "\" 'définit le chemin d'accès CA
Set OA = CD.Worksheets("A") 'définit l'onglet OA
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set CS = Workbooks("B1.xlsx") 'définit le classeur source CS (génère une erreur s'il n'est pas ouvert)
If Err <> 0 Then 'condition : si une erreur a été générée
    Err.Clear 'supprime l'erreur
    Set CS = Application.Workbooks.Open(CA & "B1.xlsm") 'définit le classeur source SC (en l'ouvrant)
End If 'fin  de la condition
On Error GoTo 0 'fin de la gestion des erreurs
Set OS = CS.Worksheets("base") 'définit l'onglet source OS
TS = OS.Range("A1").CurrentRegion 'définit la tableau source TS
TD = OA.Range("A1").CurrentRegion 'définit la tableau destination TD
For I = 2 To UBound(TD, 1) 'boucle 1 sur toutes les lignes I du tableau detination TD (en partant de la seconde)
    K = 1: Erase TL 'initialise la variable K, vide le tableau ds lignes TL
    On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
    Set OD = Worksheets(TD(I, 1)) 'définit l'onglet destination OD (génère une erreur si l'onglet n'existe pas)
    If Err <> 0 Then 'condition : si une erreur a été générée
        Err.Clear 'supprime l'erreur
        Set OD = CD.Application.Worksheets.Add 'définit l'onglet OD (en ajoutant un onglet vierge)
        OD.Move After:=Sheets(Sheets.Count) 'repositionne l'onglet OD en dernière position
        OD.Name = TD(I, 1) 'renomme l'onglet OD
        OD.Range("A1").Resize(1, UBound(TS, 2)).Value = Application.Index(TS, 1) 'récupère la première ligne du tableau source TS
        With OD.Rows(1).Cells 'prend en compte la ligne 1 de l'onglet OD
            .HorizontalAlignment = xlCenter 'alignement horizontal centré
            .VerticalAlignment = xlCenter 'alignement vertical centré
            .WrapText = True 'renvoie des mots à la ligne
        End With 'fin de la prise en compte la ligne 1 de l'onglet OD
        OD.Range("A2").Resize(1, UBound(TS, 2)).Value = Application.Index(TS, 2) 'récupère la seconde ligne du tableau source TS
    End If 'fin de la condition
    On Error GoTo 0 'fin de la gestion des erreurs
    LI = OD.Cells(Application.Rows.Count, "A").End(xlUp).Row + 1 'définit la ligne LI
    For J = 3 To UBound(TS, 1) 'boucle 2 : sur toutes ligne J du tableau source TS (en partant de la troisième)
        If TD(I, 4) = TS(J, 1) Then 'condition : si la donnée ligne I colonne 4 du tableau destination TD est égale à la donnée ligne J colonne 1 du tableau source TS
            ReDim Preserve TL(1 To UBound(TS, 2), 1 To K) 'redimensionne le tableau des lignes TL (autant de ligne que TS a de colonnes, K colonnes)
            For L = 1 To UBound(TS, 2) 'boucle 3 : sur toutes colonnes K du tableau source TS
                TL(L, K) = TS(J, L) 'récupère dans la ligne L de TL la donnée en colonne L de TS (=> trasposition)
            Next L 'prochaine colonne de la boucle 3
            K = K + 1 'incrémente K'ajoute une colonne au tableau des lignes
        End If 'fin de la condition
    Next J 'prochaine colonne de la boucle 2
    'si K est supérieure à 1, rnvoie le tableau TL tranposé dans la cellule ligne LI colonne A redimensionnée
    If K > 1 Then OD.Cells(LI, "A").Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL)
Next I 'prochaine ligne de la boucle 1
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub
[/COLOR]
 

ALEX1995

XLDnaute Nouveau
Merci merci Robert, ça marche très bien.

Ce serait possible de rajouter une conditions à la création de l'onglet navire? il créé un onglet si la date de fin n'est pas dépassé de 7 jours. Et si elle est dépassé de 7 jours la macro supprime l'onglet automatiquement.

c'est vraiment gentil de prendre du temps pour les autres même si c'est votre passion, ça se respecte :)

A bientôt,

Alex
 

Robert

XLDnaute Barbatruc
Re,

Le code modifié (non testé) :

VB:
Option Explicit

Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OA As Worksheet 'déclare la variable OA (Onglet A)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim TD As Variant 'déclare la variable TD (Tableau Destination)
Dim TS As Variant 'déclare la variable TS (Tableau Source)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim L As Byte 'déclare la variable L (incrément)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
Dim LI As Integer 'déclare la variable LI (Ligne)
Dim DA As Long 'déclare la variable DA (Date Aujourd'hui)
Dim DN As Long 'déclare la variable DN (Date Navire)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CD = ThisWorkbook 'définit le classeru destination CD
CA = CD.Path & "\" 'définit le chemin d'accès CA
Set OA = CD.Worksheets("A") 'définit l'onglet OA
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set CS = Workbooks("B1.xlsx") 'définit le classeur source CS (génère une erreur s'il n'est pas ouvert)
If Err <> 0 Then 'condition : si une erreur a été générée
    Err.Clear 'supprime l'erreur
    Set CS = Application.Workbooks.Open(CA & "B1.xlsm") 'définit le classeur source SC (en l'ouvrant)
End If 'fin  de la condition
On Error GoTo 0 'fin de la gestion des erreurs
Set OS = CS.Worksheets("base") 'définit l'onglet source OS
TS = OS.Range("A1").CurrentRegion 'définit la tableau source TS
TD = OA.Range("A1").CurrentRegion 'définit la tableau destination TD
DA = CLng(DateSerial(Year(Date), Month(Date), Day(Date)))
For I = 2 To UBound(TD, 1) 'boucle 1 sur toutes les lignes I du tableau detination TD (en partant de la seconde)
    DN = CLng(DateSerial(Year(TD(I, 3)), Month(TD(I, 3)), Day(TD(I, 3))))
    If DA > DN + 7 Then 'condition 1 : si la date du jour est supérieure a la date de fin + 7 jours
        K = 1: Erase TL 'initialise la variable K, vide le tableau ds lignes TL
        On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
        Set OD = Worksheets(TD(I, 1)) 'définit l'onglet destination OD (génère une erreur si l'onglet n'existe pas)
        If Err <> 0 Then 'condition 2: si une erreur a été générée
            Err.Clear 'supprime l'erreur
            Set OD = CD.Application.Worksheets.Add 'définit l'onglet OD (en ajoutant un onglet vierge)
            OD.Move After:=Sheets(Sheets.Count) 'repositionne l'onglet OD en dernière position
            OD.Name = TD(I, 1) 'renomme l'onglet OD
            OD.Range("A1").Resize(1, UBound(TS, 2)).Value = Application.Index(TS, 1) 'récupère la première ligne du tableau source TS
            With OD.Rows(1).Cells 'prend en compte la ligne 1 de l'onglet OD
                .HorizontalAlignment = xlCenter 'alignement horizontal centré
                .VerticalAlignment = xlCenter 'alignement vertical centré
                .WrapText = True 'renvoie des mots à la ligne
            End With 'fin de la prise en compte la ligne 1 de l'onglet OD
            OD.Range("A2").Resize(1, UBound(TS, 2)).Value = Application.Index(TS, 2) 'récupère la seconde ligne du tableau source TS
        End If 'fin de la condition 2
        On Error GoTo 0 'fin de la gestion des erreurs
        LI = OD.Cells(Application.Rows.Count, "A").End(xlUp).Row + 1 'définit la ligne LI
        For J = 3 To UBound(TS, 1) 'boucle 2 : sur toutes ligne J du tableau source TS (en partant de la troisième)
            If TD(I, 4) = TS(J, 1) Then 'condition 3 : si la donnée ligne I colonne 4 du tableau destination TD est égale à la donnée ligne J colonne 1 du tableau source TS
                ReDim Preserve TL(1 To UBound(TS, 2), 1 To K) 'redimensionne le tableau des lignes TL (autant de ligne que TS a de colonnes, K colonnes)
                For L = 1 To UBound(TS, 2) 'boucle 3 : sur toutes colonnes K du tableau source TS
                    TL(L, K) = TS(J, L) 'récupère dans la ligne L de TL la donnée en colonne L de TS (=> trasposition)
                Next L 'prochaine colonne de la boucle 3
                K = K + 1 'incrémente K'ajoute une colonne au tableau des lignes
            End If 'fin de la condition 3
        Next J 'prochaine colonne de la boucle 2
        'si K est supérieure à 1, rnvoie le tableau TL tranposé dans la cellule ligne LI colonne A redimensionnée
        If K > 1 Then OD.Cells(LI, "A").Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL)
    End If 'fin de la condition 1
Next I 'prochaine ligne de la boucle 1
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub
 

ALEX1995

XLDnaute Nouveau
Bonjour Robert,

je te remercie pour ta réponse. Cependant j'ai un petit soucis que j'ai tenté de résoudre sans succés. L'onglet que j'appel "base" est en réalité composé de plus 70000 lignes et la variable "UBound(TS, 1)" ne semble pas fonctionner pour autant de ligne. j'ai un message " Dépassement de capacité " qui s'affiche.

si quelqu’un pouvait m'aider svp?

Je vous remercie d'avance,

Alex
 

job75

XLDnaute Barbatruc
Bonjour ALEX1995, Robert,

Ce qui ne va pas avec 70000 lignes c'est Application.Transpose(TL) car cette fonction est limitée à 65536 lignes.

Mais Robert va vous arranger ça j'en suis sûr :)

A+
 

Discussions similaires


Haut Bas