Recopie valeurs dans un tableauRésolu

Question

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.

Patrice33740 · Answer

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.

JUANABIBI · Answer

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

JUANABIBI · Answer

Bonjour,

Voici donc le principe du fichier de départ …



J'aimerais arriver à ceci :



Je nettoie le code et l'envoie.

JUANABIBI · Answer

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.

Patrice33740 · Answer

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

JUANABIBI · Answer

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

JUANABIBI · Answer

Voici l'erreur :

JUANABIBI · Answer

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

JUANABIBI · Answer

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 !

JUANABIBI · Answer

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.

JUANABIBI · Answer

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 !

Recopie valeurs dans un tableau

11 réponses

Votre réponse