Recopie valeurs dans un tableau [Résolu]

Question

Recopie valeurs dans un tableau [Résolu]

Signaler

JUANABIBI

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

- 17 mars 2020 à 11:50
JUANABIBI

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

- 23 mars 2020 à 16:56

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.

Afficher la suite

A voir également:

Recopie valeurs dans un tableau
Trouver la plus grande valeur d'un tableau java - Guide
Insérer une valeur dans un tableau trié algorithme - Guide
Ajouter une valeur dans un tableau java - Forum - Java
Effacer toutes les occurrences d'une valeur dans un tableau - Forum - C
Programme permetant d'afficher le nombre de discontinuite de valeur d'un tableau - Codes sources - C / C++ / C++.NET (Maths & Algorithmes)

11 réponses

Réponse 2 / 11

Patrice33740

Messages postés: 8212
Date d'inscription: dimanche 13 juin 2010
Statut: Membre
Dernière intervention: 22 octobre 2020

19
22 mars 2020 à 18:25

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

Réponse 3 / 11

JUANABIBI

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

19 mars 2020 à 13:33

Ok, je vais faire un screen de ce dont j'ai besoin.

Réponse 4 / 11

JUANABIBI

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

22 mars 2020 à 12:04

Bonjour,

Voici donc le principe du fichier de départ …

J'aimerais arriver à ceci :

Je nettoie le code et l'envoie.

Réponse 5 / 11

JUANABIBI

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

Modifié le 22 mars 2020 à 16:33

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.

Réponse 6 / 11

JUANABIBI

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

22 mars 2020 à 19:35

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 ;)

Signaler

Patrice33740

Messages postés: 8212
Date d'inscription: dimanche 13 juin 2010
Statut: Membre
Dernière intervention: 22 octobre 2020

19
22 mars 2020 à 21:01

Quelle erreur ?
Le fichier source contiendrait-il des cellules fusionnées ?

Signaler

JUANABIBI

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

> Patrice33740

Messages postés: 8212
Date d'inscription: dimanche 13 juin 2010
Statut: Membre
Dernière intervention: 22 octobre 2020

23 mars 2020 à 08:18

Bonjour,
Oui, mais pas dans les lignes sélectionnées, désolé pour l'omission !

Réponse 7 / 11

JUANABIBI

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

23 mars 2020 à 08:26

Voici l'erreur :

Réponse 8 / 11

JUANABIBI

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

Modifié le 23 mars 2020 à 08:44

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 ...

Signaler

Patrice33740

Messages postés: 8212
Date d'inscription: dimanche 13 juin 2010
Statut: Membre
Dernière intervention: 22 octobre 2020

19
23 mars 2020 à 12:40

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

Réponse 9 / 11

JUANABIBI

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

Modifié le 23 mars 2020 à 15:30

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 !

Réponse 10 / 11

JUANABIBI

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

Modifié le 23 mars 2020 à 15:36

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.

Réponse 11 / 11

JUANABIBI

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

23 mars 2020 à 16:56

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 !

Répondre Posez votre question

Quelle erreur ?
Le fichier source contiendrait-il des cellules fusionnées ?
Bonjour,
Oui, mais pas dans les lignes sélectionnées, désolé pour l'omission !
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

Patrice33740 · Accepted Answer · 2020-03-18T10:30:33+0100

Réponse 1 / 11

Patrice33740

Messages postés: 8212
Date d'inscription: dimanche 13 juin 2010
Statut: Membre
Dernière intervention: 22 octobre 2020

19
18 mars 2020 à 10:30

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.

Votre réponse