Recopie valeurs dans un tableau

Résolu
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.

11 réponses

Patrice33740
Messages postés
8549
Date d'inscription
dimanche 13 juin 2010
Statut
Membre
Dernière intervention
7 mai 2022
21
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.
1
Patrice33740
Messages postés
8549
Date d'inscription
dimanche 13 juin 2010
Statut
Membre
Dernière intervention
7 mai 2022
21
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


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

Vous n’avez pas trouvé la réponse que vous recherchez ?

Posez votre question
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.
0
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 ;)
0
Patrice33740
Messages postés
8549
Date d'inscription
dimanche 13 juin 2010
Statut
Membre
Dernière intervention
7 mai 2022
21
22 mars 2020 à 21:01
Quelle erreur ?
Le fichier source contiendrait-il des cellules fusionnées ?
0
JUANABIBI
Messages postés
40
Date d'inscription
mardi 17 mars 2020
Statut
Membre
Dernière intervention
10 avril 2020
> Patrice33740
Messages postés
8549
Date d'inscription
dimanche 13 juin 2010
Statut
Membre
Dernière intervention
7 mai 2022

23 mars 2020 à 08:18
Bonjour,
Oui, mais pas dans les lignes sélectionnées, désolé pour l'omission !
0
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 :
0
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 ...
0
Patrice33740
Messages postés
8549
Date d'inscription
dimanche 13 juin 2010
Statut
Membre
Dernière intervention
7 mai 2022
21
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
0
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 !
0
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.
0
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 !
0