Recopie valeurs dans un tableau [Résolu]

Signaler
Messages postés
40
Date d'inscription
mardi 17 mars 2020
Statut
Membre
Dernière intervention
10 avril 2020
-
Messages postés
40
Date d'inscription
mardi 17 mars 2020
Statut
Membre
Dernière intervention
10 avril 2020
-
Bonjour,
Je souhaite automatiser le traitement des employés avec une analyse des fichiers excel (Formaté) qu'ils m'envoient vers un tableau de synthèse.
Je n'ai pas besoin de récupérer l'ensemble des données, mais uniquement certaines colonnes sur l'ensemble des lignes d'une plage donnée.
J'ai fait quelques recherches, mais rien de concret.

Les colonnes à récupérer A; C; H; L; M; N; O; P; Q.
Le nombre de lignes peut aller jusqu’à 15.

L'idée est d'aller pointer un fichier excel, l'ouvrir "caché, puis extraire les données afin de les intégrer dans le tableau de synthèse.

J'ai essayé ceci :

For each Cell in Sheets("Rapport").Range("A2:F12").Cells

    Sheets("Global").Range("A" & cell).Value = Range(cell).Value

Next cell


Je ne sais pas si la base est bonne.

Merci beaucoup de votre aide.

11 réponses

Messages postés
8128
Date d'inscription
dimanche 13 juin 2010
Statut
Membre
Dernière intervention
24 juin 2020
19
Bonjour,

Ce que tu as écrit ne fonctionne pas.

Un screen des données d'origine et un du résultat attendu seraient les bienvenus.
Messages postés
8128
Date d'inscription
dimanche 13 juin 2010
Statut
Membre
Dernière intervention
24 juin 2020
19
Bonjour,

Voila ce que j'aurais écrit :
Option Explicit
Sub Import_Frais()
Dim nomFichier As Variant
Dim wbkImport As Workbook
Dim wshSource As Worksheet
Dim cellCible As Range
Dim derniereLigne As Long
Const premiereLigne As Long = 10
Const colonnesEnTrop$ = "H:J,L:Z"
    
    ' Choisir le fichier source
    nomFichier = Application.GetOpenFilename("Fichiers Source (*.xls*), *.xls*")
    If nomFichier = False Then Exit Sub
    'Geler l'affichage écran
    Application.ScreenUpdating = False
    ' Ouvrir une copie non enregistrée du fichier source
    Set wbkImport = Workbooks.Add(nomFichier)
    Set wshSource = wbkImport.Worksheets(1)
    ' Vérifier l'existance des données
    With wshSource
      derniereLigne = .Cells(.Rows.Count, "A").End(xlUp).Row
      If derniereLigne < premiereLigne Then
        Application.ScreenUpdating = True
        MsgBox "L'import est annulé : pas de données à importer", vbExclamation, "Avertissement"
        wbkImport.Close False
        Exit Sub
      End If
      ' Supprimer les données inutiles
      .Rows("1:" & premiereLigne - 1).Delete     ' lignes 1 à 9
      .Range(colonnesEnTrop).Delete              ' colonnes H à J et L à Z
      ' Permuter les colonnes B et C
      .Columns("C:C").Cut
      .Columns("B:B").Insert Shift:=xlToRight
    End With
    ' Définir la cellule cible
    With ThisWorkbook.Worksheets(1)
      Set cellCible = .Cells(.Rows.Count, "A").End(xlUp)
    End With
    ' Copier les données
    wshSource.Range("A1").CurrentRegion.Copy Destination:=cellCible
    ' Fermer le fichier import
    wbkImport.Close False
    'Dégeler l'affichage écran
    Application.ScreenUpdating = True
    
End Sub


Messages postés
40
Date d'inscription
mardi 17 mars 2020
Statut
Membre
Dernière intervention
10 avril 2020

Ok, je vais faire un screen de ce dont j'ai besoin.
Messages postés
40
Date d'inscription
mardi 17 mars 2020
Statut
Membre
Dernière intervention
10 avril 2020

Bonjour,

Voici donc le principe du fichier de départ …



J'aimerais arriver à ceci :



Je nettoie le code et l'envoie.
Messages postés
40
Date d'inscription
mardi 17 mars 2020
Statut
Membre
Dernière intervention
10 avril 2020

Voilà où j'en suis :

Sub Import_Frais()

    'Gèle l'application le temps du traitement
    Application.ScreenUpdating = False
    
    'Cherche le fichier source
    Dim Fichier
    Fichier = Application.GetOpenFilename("Fichiers Source (*.xls), *.xls")
    If VarType(Fichier) = vbBoolean Then
        MsgBox "L'import en cours est stoppé ...", vbExclamation + vbOKOnly, "Avertissement"
    Else
        Workbooks.OpenText Fichier
    End If
    
    'Traitement du fichier
    Dim Rapport As Worksheet 'Onglet où il y a les lignes à utiliser dans le fichier source
    Dim Derniere_ligne As Long
    Dim Ligne_courante As Long
    
    'Cherche la dernière ligne pour créer la boucle
    Derniere_ligne = Rapport.Cells(Rows.Count, 1).End(xlUp).Row
    
    'Boucle depuis la ligne voulue jusqu'a la dernière ligne précedemment trouvée
    For Ligne_courante = 10 To Derniere_ligne
        'Recopie des lignes du fichier source au fichier destination
    Next

    'Dégèle l'application en fin de traitement
    Application.ScreenUpdating = True
    
End Sub


Pour le moment, je pense qu'il faut faire ligne par ligne, ensuite je verrais pour l'ajout de ligne dans le tableau récepteur.

Merci infiniment de votre aide.
Messages postés
40
Date d'inscription
mardi 17 mars 2020
Statut
Membre
Dernière intervention
10 avril 2020

Merci beaucoup, je ne pensais pas que ça aurait pu fonctionner en copiant l'intégralité et collant ensuite les colonnes voulues.

Il me reste une erreur avec le . delete à la ligne ici :

      .Range(colonnesEnTrop).Delete              ' colonnes H à J et L à Z


Je cherche ;)
Messages postés
8128
Date d'inscription
dimanche 13 juin 2010
Statut
Membre
Dernière intervention
24 juin 2020
19
Quelle erreur ?
Le fichier source contiendrait-il des cellules fusionnées ?
Messages postés
40
Date d'inscription
mardi 17 mars 2020
Statut
Membre
Dernière intervention
10 avril 2020
>
Messages postés
8128
Date d'inscription
dimanche 13 juin 2010
Statut
Membre
Dernière intervention
24 juin 2020

Bonjour,
Oui, mais pas dans les lignes sélectionnées, désolé pour l'omission !
Messages postés
40
Date d'inscription
mardi 17 mars 2020
Statut
Membre
Dernière intervention
10 avril 2020

Voici l'erreur :
Messages postés
40
Date d'inscription
mardi 17 mars 2020
Statut
Membre
Dernière intervention
10 avril 2020

Voici le code actuel :

Option Explicit

Sub Import_Frais()
Dim nomFichier As Variant
Dim wbkImport As Workbook
Dim wshSource As Worksheet
Dim cellCible As Range
Dim derniereLigne As Long
Const premiereLigne As Long = 10
Const colonnesEnTrop$ = "H:J,L:Z"
    
    ' Choisir le fichier source
    nomFichier = Application.GetOpenFilename("Fichiers Source (*.xls*), *.xls*")
    If nomFichier = False Then Exit Sub
    
    'Geler l'affichage écran
    Application.ScreenUpdating = False
    
    ' Ouvrir une copie non enregistrée du fichier source
    Set wbkImport = Workbooks.Add(nomFichier)
    Set wshSource = wbkImport.Worksheets(1)
    
    ' Vérifier l'existance des données
    With wshSource
      derniereLigne = .Cells(.Rows.Count, "A").End(xlUp).Row
      If derniereLigne < premiereLigne Then
        Application.ScreenUpdating = True
        MsgBox "L'import est annulé : pas de données à importer", vbExclamation, "Avertissement"
        wbkImport.Close False
        Exit Sub
      End If
      
      'Suppression des des liens HT
      .Hyperlinks.Delete
      
      'On dévérouille la feuille
      .Range("A1:Z99").Locked = False
      
      'Enlève les cellules fusionnées avant traitement
      .Range("B6, F6, H6").MergeArea.ClearContents
      
      ' Supprimer les données inutiles
      .Rows("1:" & premiereLigne - 1).Delete     ' lignes 1 à 9
      .Range(colonnesEnTrop).Delete              ' colonnes H à J et L à Z
      
      ' Permuter les colonnes B et C
      .Columns("C:C").Cut
      .Columns("B:B").Insert Shift:=xlToRight
      
    End With
    
    ' Définir la cellule cible
    With ThisWorkbook.Worksheets(1)
      Set cellCible = .Cells(.Rows.Count, "A").End(xlUp)
    End With
    
    ' Copier les données
    wshSource.Range("A1").CurrentRegion.Copy Destination:=cellCible
    
    ' Fermer le fichier import
    wbkImport.Close False
    
    'Dégeler l'affichage écran
    Application.ScreenUpdating = True
    
End Sub


Je viens de me rendre compte d'une chose, c'est que les cellules sont dans un tableau, je progresse pour supprimer tout ça ...
Messages postés
8128
Date d'inscription
dimanche 13 juin 2010
Statut
Membre
Dernière intervention
24 juin 2020
19
Bonjour,

Essaies :
Option Explicit
Sub Import_Frais()
Dim nomFichier As Variant
Dim valeurs As Variant
Dim wbkImport As Workbook
Dim wshSource As Worksheet
Dim cellCible As Range
Dim derniereLigne As Long
Const premiereLigne As Long = 10
Const colonnesEnTrop$ = "H:J,L:Z"
    
    ' Choisir le fichier source
    nomFichier = Application.GetOpenFilename("Fichiers Source (*.xls*), *.xls*")
    If nomFichier = False Then Exit Sub
    'Geler l'affichage écran
    Application.ScreenUpdating = False
    ' Ouvrir une copie non enregistrée du fichier source
    Set wbkImport = Workbooks.Add(nomFichier)
    Set wshSource = wbkImport.Worksheets(1)
    ' Vérifier l'existance des données
    With wshSource
      derniereLigne = .Cells(.Rows.Count, "A").End(xlUp).Row
      If derniereLigne < premiereLigne Then
        Application.ScreenUpdating = True
        MsgBox "L'import est annulé : pas de données à importer", vbExclamation, "Avertissement"
        wbkImport.Close False
        Exit Sub
      End If
      ' Supprimer les Hyperliens
      .Hyperlinks.Delete
      ' Enlever les cellules fusionnées
      .UsedRange.UnMerge
      ' Supprimer les formules
      .UsedRange.Value = .UsedRange.Value
      ' Supprimer les données inutiles
      .Rows("1:" & premiereLigne - 1).Delete     ' lignes 1 à 9
      .Range(colonnesEnTrop).Delete              ' colonnes H à J et L à Z
      ' Permuter les colonnes B et C
      .Columns("C:C").Cut
      .Columns("B:B").Insert Shift:=xlToRight
      ' Mémoriser les valeurs
      valeurs = .Range("A1").CurrentRegion.Value
    End With
    ' Définir la cellule cible
    With ThisWorkbook.Worksheets(1)
      Set cellCible = .Cells(.Rows.Count, "A").End(xlUp)
    End With
    ' Copier les données
    cellCible.Resize(UBound(valeurs), UBound(valeurs, 2)) = valeurs
    ' Fermer le fichier import
    wbkImport.Close False
    'Dégeler l'affichage écran
    Application.ScreenUpdating = True
    
End Sub
Messages postés
40
Date d'inscription
mardi 17 mars 2020
Statut
Membre
Dernière intervention
10 avril 2020

Merci Patrice,

Alors j'ai bien avancé, regarde :

Option Explicit

Sub Import_Frais()
Dim nomFichier As Variant
Dim wbkImport As Workbook
Dim wshSource As Worksheet
Dim cellCible As Range
Dim derniereLigne As Long
Dim cellule As Variant
Dim i As Double
Const premiereLigne As Long = 11
Const colonnesEnTrop$ = "H:J,L:Z"
    
    ' Choisir le fichier source
    nomFichier = Application.GetOpenFilename("Fichiers Source (*.xlsx*), *.xlsx*")
    If nomFichier = False Then Exit Sub
    
    'Geler l'affichage écran
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' Ouvrir une copie non enregistrée du fichier source
    Set wbkImport = Workbooks.Add(nomFichier)
    Set wshSource = wbkImport.Worksheets(1)
    
    Workbooks.Add(nomFichier).Sheets("Rapport").ListObjects("Source_1").ShowHeaders = False

    ' Vérifier l'existence des données
    With wshSource
      derniereLigne = .Cells(.Rows.Count, "A").End(xlUp).Row
      If derniereLigne < premiereLigne Then
        Application.ScreenUpdating = True
        MsgBox "L'import est annulé : Aucun fichier choisi !", vbExclamation, "Avertissement"
        wbkImport.Close False
        Exit Sub
      End If
      
      
      'Suppression des des liens HT
      .Hyperlinks.Delete
      
      'On dévérouille la feuille
      .Range("A1:G37").Locked = False
      
      'Enlève les cellules fusionnées avant traitement
      .Range("B6").MergeArea.ClearContents
      .Range("F6").MergeArea.ClearContents
      .Range("H6").MergeArea.ClearContents
    
      ' Supprimer les données inutiles
      .Rows("1:" & premiereLigne - 1).Delete
      
      .Columns("B").EntireColumn.Delete
      
      For i = 1 To 4
      .Columns("C").EntireColumn.Delete
      Next
      
      For i = 1 To 4
      .Columns("D").EntireColumn.Delete
      Next
      
      For i = 1 To 12
      .Columns("G").EntireColumn.Delete
      Next

      End With
      
      ' Définir la cellule cible
      With ThisWorkbook.Worksheets(1)
      Set cellCible = .Cells(.Rows.Count, "B").End(xlUp)
      End With
      
      ' Copier les données
      wshSource.Range("A1").CurrentRegion.Copy
      
      'Coller les données
      ThisWorkbook.Worksheets("Rapport").Range("B7").PasteSpecial xlPasteValues
      
      ' Fermer le fichier import
      wbkImport.Close False
      
      'Enlève le soulignement
      For Each cellule In Worksheets("Rapport").Range("A1:F9").Cells
         If cellule.Value <> "" Then
            With Selection.Font
               .Underline = xlUnderlineStyleNone
               .ColorIndex = xlAutomatic
               .Size = 12
               .Italic = False
               .Bold = False
            End With
         End If
      Next

      'Dégeler l'affichage écran
      Application.ScreenUpdating = True
      
End Sub



Il ne me reste que le début de code concernant l'entête du tableau !
Je persiste ;)

Merci pour ton aide !
Messages postés
40
Date d'inscription
mardi 17 mars 2020
Statut
Membre
Dernière intervention
10 avril 2020

Patrice, j'ai une erreur :



Concernant l'enlèvement de l'entête du tableau initial, si je passe par l'enregistreur de macros, voici ce qu'il me donne :

ActiveSheet.ListObjects("Source_1").ShowHeaders = False


Je n'arrive pas à le transposer dans mon cas.
Messages postés
40
Date d'inscription
mardi 17 mars 2020
Statut
Membre
Dernière intervention
10 avril 2020

Voilà, j'ai fini le code nécessaire.

Option Explicit

Sub Import_Frais()
Dim nomFichier As Variant
Dim wbkImport As Workbook
Dim wshSource As Worksheet
Dim cellCible As Range
Dim derniereLigne As Long
Dim cellule As Variant
Dim i As Double
Const premiereLigne As Long = 11
    
    ' Choisir le fichier source
    nomFichier = Application.GetOpenFilename("Fichiers Source (*.xlsx*), *.xlsx*")
    If nomFichier = False Then Exit Sub
    
    'Geler l'affichage écran
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' Ouvrir une copie non enregistrée du fichier source
    Set wbkImport = Workbooks.Add(nomFichier)
    Set wshSource = wbkImport.Worksheets(1)
    


    ' Vérifier l'existence des données
    With wshSource

      derniereLigne = .Cells(.Rows.Count, "A").End(xlUp).Row
      If derniereLigne < premiereLigne Then
        Application.ScreenUpdating = True
        MsgBox "L'import est annulé : Aucun fichier choisi !", vbExclamation, "Avertissement"
        wbkImport.Close False
        Exit Sub
      End If

      'Suppression de l'entete
      .ListObjects("Source_1").ShowHeaders = False

      'On dévérouille la feuille
      .Range("A1:G37").Locked = False
      
      'Enlève les cellules fusionnées avant traitement
      .Range("B6").MergeArea.ClearContents
      .Range("F6").MergeArea.ClearContents
      .Range("H6").MergeArea.ClearContents
    
      ' Supprimer les données inutiles
      .Rows("1:" & premiereLigne - 1).Delete
      
      .Rows("1").EntireRow.Delete
      .Columns("B").EntireColumn.Delete
      
      For i = 1 To 4
      .Columns("C").EntireColumn.Delete
      Next
      
      For i = 1 To 4
      .Columns("D").EntireColumn.Delete
      Next
      
      .Columns("G").EntireColumn.Delete
      
      For i = 1 To 12
      .Columns("H").EntireColumn.Delete
      Next

      End With
      
      ' Définir la cellule cible
      With ThisWorkbook.Worksheets(1)
      Set cellCible = .Cells(.Rows.Count, "B").End(xlUp)
      End With
      
      ' Copier les données partie 1
      wshSource.Range("A1").CurrentRegion.Copy
      
      'Coller les données partie 1
      ThisWorkbook.Worksheets("Global").Range("B7").PasteSpecial xlPasteValues
      
      ' Copier les données partie 2
      wshSource.Range("G1").CurrentRegion.Copy
      
      'Coller les données partie 2
      ThisWorkbook.Worksheets("Global").Range("H7").PasteSpecial xlPasteValues
      
      ' Fermer le fichier import
      wbkImport.Close False
      
      'Dégeler l'affichage écran
      Application.ScreenUpdating = True
      
End Sub




Encore un grand merci à toi Patrice !