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
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre questionSub 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
.Range(colonnesEnTrop).Delete ' colonnes H à J et L à Z
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
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
ActiveSheet.ListObjects("Source_1").ShowHeaders = False
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