macro extraction d'un fichier excel vers un autre

L

_Loverbot

XLDnaute Nouveau
Bonjour,

J'ai construit la macro suivante pour effectuer une extraction à partir d'un fichier principal (Fichier_Source) vers un fichier secondaire (Synthèse_Nom_X), respectant trois conditions différentes :

Condition 1 : correspondance du Nom
Condition 2 : donnée inférieure ou égale à une borne supérieure (mensuelle, en nombre)
Condition 3 : donnée supérieure ou égale à une borne inférieure (mensuelle, en nombre)

Code: 
Sub export_nom_x()

Dim DernièreLigne As Long
Dim i As Long

DernièreLigne = [A65536].End(xlUp).Row

For i = 3 To DernièreLigne

   If Sheets("BASE 2016").Range("BY" & i) = "Nom_X" Then

       If Sheets("BASE 2016").Range("BZ" & i) <= Sheets("OP").Range("J14") Then     'définition borne mensuelle supérieure

         If Sheets("BASE 2016").Range("BZ" & i) >= Sheets("OP").Range("H14") Then    'définition borne mensuelle inférieure
 
         Sheets("BASE 2016").Range("BO" & i).Copy
         Workbooks("Synthèse_Nom_X.xlsm").Sheets("base").Range("A" & i).PasteSpecial Paste:=xlPasteValues
      
         Sheets("BASE 2016").Range("BP" & i).Copy
         Workbooks("Synthèse_Nom_X.xlsm").Sheets("base").Range("B" & i).PasteSpecial Paste:=xlPasteValues
      
         Sheets("BASE 2016").Range("BQ" & i).Copy
         Workbooks("Synthèse_Nom_X.xlsm").Sheets("base").Range("C" & i).PasteSpecial Paste:=xlPasteValues
      
         Sheets("BASE 2016").Range("BR" & i).Copy
         Workbooks("Synthèse_Nom_X.xlsm").Sheets("base").Range("D" & i).PasteSpecial Paste:=xlPasteValues
      
         Sheets("BASE 2016").Range("BS" & i).Copy
         Workbooks("Synthèse_Nom_X.xlsm").Sheets("base").Range("E" & i).PasteSpecial Paste:=xlPasteValues
      
         Sheets("BASE 2016").Range("BT" & i).Copy
         Workbooks("Synthèse_Nom_X.xlsm").Sheets("base").Range("F" & i).PasteSpecial Paste:=xlPasteValues
      
         Sheets("BASE 2016").Range("BU" & i).Copy
         Workbooks("Synthèse_Nom_X.xlsm").Sheets("base").Range("G" & i).PasteSpecial Paste:=xlPasteValues
      
         Sheets("BASE 2016").Range("BV" & i).Copy
         Workbooks("Synthèse_Nom_X.xlsm").Sheets("base").Range("H" & i).PasteSpecial Paste:=xlPasteValues
      
         Sheets("BASE 2016").Range("BW" & i).Copy
         Workbooks("Synthèse_Nom_X.xlsm").Sheets("base").Range("I" & i).PasteSpecial Paste:=xlPasteValues
        
         Sheets("BASE 2016").Range("BX" & i).Copy
         Workbooks("Synthèse_Nom_X.xlsm").Sheets("base").Range("J" & i).PasteSpecial Paste:=xlPasteValues
      
         Sheets("BASE 2016").Range("BY" & i).Copy
         Workbooks("Synthèse_Nom_X.xlsm").Sheets("base").Range("K" & i).PasteSpecial Paste:=xlPasteValues

         End If
      
       End If

    End If
    
Next i
            
Workbooks("Synthèse_Nom_X.xlsm").Sheets("base").Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
      
End Sub

Lorsque j'exécute la macro, en laissant les deux fichiers ouverts, aucune donnée n'est visiblement exportée du Fichier_Source vers la Synthèse_Nom_X, même si, quand je ferme le dernier fichier, Excel me propose d'enregistrer les modifications, prouvant qu'une opération a malgré tout eu lieu.

J'avais réussi à faire fonctionner la macro plusieurs fois avant de mettre en place les bornes mensuelles (conditions 2 et 3), depuis je ne suis plus parvenu à extraire la moindre donnée, et Excel ne m'affiche aucune erreur.

Tout cela me dépasse, j'ai cherché pendant des heures sans succès. Je me tourne donc vers ce forum et ses utilisateurs chevronnés (dont le talent ne sera pas nécessairement sollicité puisque l'erreur est sûrement toute bête :mad:).

Je reste ouvert également à de meilleures propositions pour effectuer cette opération !

Je vous remercie d'avance et vous souhaite une bonne journée.
 

Pièces jointes

  • Fichier_Source.xlsm
    33.2 KB · Affichages: 38
  • Synthèse_Nom_X.xlsm
    18.4 KB · Affichages: 34
  • Fichier_Source.xlsm
    33.2 KB · Affichages: 44
Trier par date Trier par votes
B

Bebere

XLDnaute Barbatruc
Re : macro extraction d'un fichier excel vers un autre

bonjour loverbot
bienvenue

Dim DernièreLigne As Long
Dim i As Long
Application.ScreenUpdating = False
DernièreLigne = Sheets("BASE 2016").[A65536].End(xlUp).Row

For i = 3 To DernièreLigne

If Sheets("BASE 2016").Range("BY" & i) = "Nom_X" Then
a = Sheets("BASE 2016").Range("BZ" & i).Value: b = Sheets("OP").Range("J14").Value
If Sheets("BASE 2016").Range("BZ" & i).Value >= Sheets("OP").Range("H14").Value And Sheets("BASE 2016").Range("BZ" & i) <= Sheets("OP").Range("J14").Value Then 'définition borne mensuelle supérieure

' If Sheets("BASE 2016").Range("BZ" & i) >= Sheets("OP").Range("H14") Then 'définition borne mensuelle inférieure

Sheets("BASE 2016").Range("BO" & i).Copy
Workbooks("Synthèse_Nom_X.xlsm").Sheets("base").Range("A" & i).PasteSpecial Paste:=xlPasteValues

Sheets("BASE 2016").Range("BP" & i).Copy
Workbooks("Synthèse_Nom_X.xlsm").Sheets("base").Range("B" & i).PasteSpecial Paste:=xlPasteValues

Sheets("BASE 2016").Range("BQ" & i).Copy
Workbooks("Synthèse_Nom_X.xlsm").Sheets("base").Range("C" & i).PasteSpecial Paste:=xlPasteValues

Sheets("BASE 2016").Range("BR" & i).Copy
Workbooks("Synthèse_Nom_X.xlsm").Sheets("base").Range("D" & i).PasteSpecial Paste:=xlPasteValues

Sheets("BASE 2016").Range("BS" & i).Copy
Workbooks("Synthèse_Nom_X.xlsm").Sheets("base").Range("E" & i).PasteSpecial Paste:=xlPasteValues

Sheets("BASE 2016").Range("BT" & i).Copy
Workbooks("Synthèse_Nom_X.xlsm").Sheets("base").Range("F" & i).PasteSpecial Paste:=xlPasteValues

Sheets("BASE 2016").Range("BU" & i).Copy
Workbooks("Synthèse_Nom_X.xlsm").Sheets("base").Range("G" & i).PasteSpecial Paste:=xlPasteValues

Sheets("BASE 2016").Range("BV" & i).Copy
Workbooks("Synthèse_Nom_X.xlsm").Sheets("base").Range("H" & i).PasteSpecial Paste:=xlPasteValues

Sheets("BASE 2016").Range("BW" & i).Copy
Workbooks("Synthèse_Nom_X.xlsm").Sheets("base").Range("I" & i).PasteSpecial Paste:=xlPasteValues

Sheets("BASE 2016").Range("BX" & i).Copy
Workbooks("Synthèse_Nom_X.xlsm").Sheets("base").Range("J" & i).PasteSpecial Paste:=xlPasteValues

Sheets("BASE 2016").Range("BY" & i).Copy
Workbooks("Synthèse_Nom_X.xlsm").Sheets("base").Range("K" & i).PasteSpecial Paste:=xlPasteValues

End If

' End If

End If

Next i

Workbooks("Synthèse_Nom_X.xlsm").Sheets("base").Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True

End Sub
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif
Paf

Paf

XLDnaute Barbatruc
Re : macro extraction d'un fichier excel vers un autre

Bonjour _Loverbot, Bebere,

une autre proposition de modification :

Code: 
Sub export_nom_x()
 Dim i As Long, Lig As Long
 Dim CS As Workbook, CC As Workbook, FS As Worksheet, FC As Worksheet
 Set CS = ThisWorkbook                 'classeur source
 Set CC = Workbooks("Xl0000018.xls")   'classeur cible
 Set FS = CS.Sheets("BASE 2016")       'feuille source
 Set FC = CC.Sheets("base")            'feuille cible

 Application.ScreenUpdating = False

 For i = 3 To FS.Range("A" & Rows.Count).End(xlUp).Row
   If FS.Range("BY" & i) = "Nom_X" Then
       If FS.Range("BZ" & i) <= CS.Sheets("OP").Range("J14") Then     'définition borne mensuelle supérieure
         If FS.Range("BZ" & i) >= CS.Sheets("OP").Range("H14") Then    'définition borne mensuelle inférieure
            Lig = FC.Range("A" & Rows.Count).End(xlUp).Row + 1      'première ligne dispo du classeur cible
            FS.Range("BO" & i).Copy FC.Range("A" & Lig)
            FS.Range("BP" & i).Copy FC.Range("B" & Lig)
            FS.Range("BQ" & i & ":BY" & i).Copy FC.Range("C" & Lig) ' évite de copier cellule par cellule
         End If
       End If
    End If
 Next i
           
 'Workbooks("Synthèse_Nom_X.xlsm").Sheets("base").Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
 Application.ScreenUpdating = True
End Sub

A+
 
Vote positif 0 Vote négatif
Robert

Robert

XLDnaute Barbatruc
Repose en paix
Re : macro extraction d'un fichier excel vers un autre

Bonjour le fil, bonjour le forum,

En retard grave ! Tant pis, j'envoie quand même...
Code: 
Sub export_nom_x()
Dim CP As Workbook 'déclare la variable CP (Classeur Principal)
Dim CH As String 'déclare la variable CH (CHemin d'accès)
Dim OP As Worksheet 'déclare la variable OP (Onglet Principal)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim CS As Workbook 'déclare la variable CS (Classeur Secondaire)
Dim OS As Worksheet 'déclare la variable OS (Onglet Secondaire)
Dim I As Long 'déclare la variable I (Incrément)

Set CP = ThisWorkbook 'définit le classeur principal CP
CH = CP.Path & "\" 'définit le chemin d'accès CH  du classeur secondaire (à adapter. Ici le même que le classeur principal)
Set OP = CP.Sheets("BASE 2016") 'définit l'onglet principal OP
TV = OP.Range("A1").CurrentRegion 'définit le tableau des valaeurs TV
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set CS = Workbooks("Synthèse_Nom_X.xlsm") 'définit le classeur secondaire CS (génère une erreur si ce classeur n'est pas ouvert)
If Err <> 0 Then 'condition : si une erreur a été générée
    Application.Workbooks.Open (CH & "Synthèse_Nom_X.xlsm") 'ouvre le classeur secondaire (chemin à adapter)
    Set CS = ActiveWorkbook 'définit le classeur secondaire CS
End If 'fin de la condition
Set OS = CS.Sheets("base") 'définit l'onglet secondaire
For I = 3 To UBound(TV, 1) 'boucle 1 : sur toutes les lignes du tabeau des valeurs TV (en partant de la troisième)
    If TV(I, 77) = "Nom_X" Then 'condition 1 : si la donnée ligne I colonne 77 (=> colonne BY) de TV est égale à "Nom_X"
        If TV(I, 78) <= Sheets("OP").Range("J14") Then 'condition 2 : si la donnée ligne I colonne BZ est inférieure ou égale à J14 de l'onglet OP du classeur CP
            If TV(I, 78) >= Sheets("OP").Range("H14") Then 'condition 3 : si la donnée ligne I colonne BZ est supérieure ou égale à H14 de l'onglet OP du classeur CP
                For J = 67 To 77 'boucle 2 : sur les colonnes 67 à 77 de TV
                    OS.Cells(I, J - 66).Value = TV(I, J) 'attribue à la cellule ligne I colonne J-66 de l'onglet OS, la valeur ligne I colonne J de TV
                Next J 'prochaine colonne de la boucle 2
            End If 'fin de la condition 3
        End If 'fin de la condition 2
    End If 'fin de la condition 1
Next I 'prichaine ligne de la boucle 1
OS.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'efface les lignes de l'onglet OS dont la cellule en colonne 1 (=A) est vide
End Sub
 
Vote positif 0 Vote négatif

Discussions similaires

Chaton77
  • Résolu(e)
Microsoft 365 Vba : Transférer des données d'un tableau dans un autre fichier
Réponses
7
Affichages
429
Chaton77
Chaton77
Z
  • Question
XL 2016 Macro pour copier plusieurs cellules vers un fichier :(
Réponses
3
Affichages
312
zendb
Z
Usine à gaz
  • Résolu(e)
XL 2021 Ecrire dans une une autre feuille
Réponses
3
Affichages
513
Usine à gaz
Usine à gaz
mouchtre
  • Résolu(e)
Microsoft 365 Macro fonctionnant avec excel 365 sur windows 11 mais ne fonctionnent pas sur un autre windows 11 avec aussi un excel 365
Réponses
11
Affichages
873
mouchtre
mouchtre
F
  • Résolu(e)
XL 2021 fermeture du classeur après apple d'un userform d'un autre classeur ouvert
Réponses
2
Affichages
316
farid
F
R
  • Résolu(e)
XL 2019 creer une macro pour copier des info d un onglet a un autre dans le meme classeur
Réponses
4
Affichages
541
robpellan52
R
R
  • Question
XL 2019 injecter fichier excel avec nom variable
Réponses
4
Affichages
616
job75
job75
A
  • Question
Microsoft 365 Cpier/coller en VBA
Réponses
7
Affichages
625
A-F
A
S
  • Résolu(e)
Autres ActiveWorkbook.Worksheets("vierge").AutoFilter.Sort.SortFields.Clear
2
Réponses
23
Affichages
2 K
AtTheOne
AtTheOne
M
  • Question
XL 2013 Envoyer un mail automatique avec le contenu de la bonne ligne
Réponses
2
Affichages
808
Oneida
Oneida
T
  • Question
XL 2016 Créer un renvoi automatique vers une feuille récap
Réponses
2
Affichages
778
thsoulard
T
G
  • Question
Microsoft 365 Incompatibilité de type - Array
Réponses
2
Affichages
449
guiyom
G
A
  • Question
Microsoft 365 Copier/coller un plusieurs lignes
Réponses
5
Affichages
749
LeSaintKebab
L
I
  • Question
XL 2016 Copier vers les feuilles avec condition
Réponses
4
Affichages
510
INFINITY100
I
H
  • Résolu(e)
XL 2019 récupérer une donnée d'un fichier csv pour le copier vers un autre
2
Réponses
27
Affichages
2 K
Hutchy33
H
X
  • Question
XL 2016 Souci copier/coller avec un filtre.
2 3 4
Réponses
55
Affichages
4 K
Xender
X
D
  • Résolu(e)
XL 2010 excel se ferme tout seul à un moment de la macro
Réponses
5
Affichages
1 K
david54520
D
J
  • Question
XL 2016 [RESOLU] Avis Code VBA excel
Réponses
9
Affichages
930
jabenj
J
J
  • Question
Microsoft 365 Macro excel spécifier chemin de sauvegarde one drive
Réponses
4
Affichages
747
.jakob@gmail.com
J
I
  • Question
XL 2016 MACRO LENTE
Réponses
2
Affichages
843
ImNotJésus
I

Membres actuellement en ligne

Aucun membre en ligne actuellement.
0 membres et 50 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 261
Messages
2 117 863
Membres
113 357
dernier inscrit
clem1536