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