XL 2013 Modifier macro importation cellules

[Etn]

Bonjour,

J'ai de temps en temps besoin d'importer des cellules de d'autres classeurs (fermés) dans un nouveau et pour cela j'utilise la macro suivante :

Sub Refinancement()

Dim FSO 'As Scripting.FileSystemObject
Dim SourceFolder 'As Scripting.Folder
Dim FileItem 'As Scripting.File
Dim chemin$
Dim T()
Dim cpt&
Dim g&
Dim i&
Dim j&
Dim Lig&
Dim var
Dim WB As Workbook
Dim S As Worksheet
Dim DEST As Worksheet
Dim Info(1 To 1, 1 To 26)
'------------
chemin$ = "V:\ordi\test"
If chemin$ = "" Then Exit Sub
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(chemin$)
If SourceFolder.Files.Count = 0 Then Exit Sub
For Each FileItem In SourceFolder.Files
  If LCase(Right(FileItem.Name, 4)) = ".xls" Or LCase(Right(FileItem.Name, 5)) = ".xlsx" Or LCase(Right(FileItem.Name, 5)) = ".xlsm" Then
  cpt& = cpt& + 1
  ReDim Preserve T(1 To cpt&)
  T(cpt&) = chemin$ & "\" & FileItem.Name
  End If
Next FileItem
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
'------------
Application.ScreenUpdating = False
Set DEST = Sheets.Add
Lig& = 1
For g& = 1 To UBound(T)
  Set WB = Workbooks.Open(Filename:=T(g&), ReadOnly:=True, UpdateLinks:=0)
  Set S = WB.Sheets("test")
  Info(1, 1) = S.Range("c1")
  Info(1, 2) = S.Range("d35")
  Info(1, 3) = S.Range("d36")
  Info(1, 4) = S.Range("e35")
  Info(1, 5) = S.Range("e36")
  WB.Close False
  Set WB = Nothing
  Lig& = Lig& + 1
  DEST.Range(DEST.Cells(Lig&, 1), _
  DEST.Cells(Lig&, UBound(Info, 2))) = Info
  Erase Info
Next g&
var = Array("Date", "nom", "prénom", "ville", "age")
With DEST
  .Range(.Cells(1, 1), .Cells(1, UBound(var) + 1)) = var
  .Range("a1:e1").Interior.ColorIndex = 6
  .Name = "Macro test"
End With
Application.ScreenUpdating = False
Exit Sub
Erreur:
Application.ScreenUpdating = False
MsgBox "Erreur " & Err.Number & vbCrLf & Err.Description
End Sub

Cela m'importe donc les cellules C1, D35, D36, etc... dans un nouvel onglet.
Néanmoins cette fois-ci j'aurais besoin d'importer deux colonnes entières (ou au moins les 500 premières lignes des colonnes A et B).

Est-il possible de modifier facilement la macro précédente ? Ou faut il ajouter les colonnes à importer cellules par cellules ?
Info(1, 1) = S.Range("A1")
Info(1, 2) = S.Range("A2")
Info(1, 3) = S.Range("A3")
Info(1, 4) = S.Range("A4")
etc...

Merci pour votre aide et bonne journée !

 

[Lolote83]

Salut ETN,
Perso, j'utilise la macro suivante pour lire des données dans un classeur FERME.
En changeant quelques paramètres tu peux donc importer soit une cellule, soit une plage de cellules
En espérant que tu puisses en tirer quelque chose
@+ Lolote83

Sub LireFichierFermé()
    Dim texte_SQL As String
    Dim xChemin As String
    Dim xFichier As String
    Dim xOnglet As String
    Dim xPlage As String
    Application.ScreenUpdating = False
    'Définition des variables
        xChemin = "M:\A-YVAN\"          'A adapter
        xFichier = "ARNAUD.xlsx"        'A adapter
        xOnglet = "Feuil1"              'A adapter
        xPlage = "A1:B10"               'A adapter
    'Connexion ADO
        Set Source = CreateObject("ADODB.Connection")
        'Avant XL 2007
            'Source.Open "Provider=Microsoft.Jet.OLEDB.4.0;data source=" & xChemin & "\" & xFichier & ";Extended Properties=""Excel 8.0;HDR=No;"";"
        'Après XL 2007
        If Right(xChemin, 1) = "\" Then
            Source.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & xChemin & xFichier & ";Extended Properties=""Excel 12.0;HDR=NO;"";"       'IMEX=1";
        Else
            Source.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & xChemin & "\" & xFichier & ";Extended Properties=""Excel 12.0;HDR=NO;"";"       'IMEX=1";
        End If
    'Exerce la requete ADO sur les donnée à recopier
        texte_SQL = "SELECT * FROM [" & xOnglet & "$" & xPlage & "]"
        Set Requete = CreateObject("ADODB.Recordset")
        Set Requete = Source.Execute(texte_SQL)
    'Ecriture des données lues dans le fichier en cours (Les données seront collées en A1)
        ActiveSheet.Range("A1").CopyFromRecordset Requete   'A adapter
    'Ferme la requete
        Set Requete = Nothing
        Set Source = Nothing
        Application.ScreenUpdating = True
End Sub

 

[Etn]

Bonjour Lolote83,

Tout d'abord merci pour ton aide, malheureusement étant donné que c'est à usage pro et que je suis sur un ordinateur de l'entreprise, je ne peux installer aucune application (comme ADO).

 

[Etn]

Finalement après quelques manips c'est passé. Ta macro marche super merci et est simple à adapter.

Néanmoins je me confronte à quelques problèmes :
- Dans le cas où je souhaiterais copier une plage de l'ensemble des fichiers d'un seul répertoire (sans spécifier les noms), et ajouter les données de chaque fichiers les uns à la suite des autres, comment puis-je faire ?

J'ai joint deux fichiers (test 1 et 2) dont les données sont à importer (à mettre dans le même répertoire) et le résultat attendu.

Encore merci pour votre aide,

Etn