macro extraction d'un fichier excel vers un autre

_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

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
 

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+
 

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
 

Discussions similaires

Réponses
7
Affichages
404