Sélectionner une feuille d'un classeur avec nom dans une cellulle d'un autre classeur

chemist

XLDnaute Junior
Bonjour j'ai un fichier qui pour l'exemple se nomme test.xlsm dans lequel j'ai une macro qui fait ouvrir les fichiers choisi d'un répertoire et qui copie bout à bout les données d'une page choisi dans la sheet1 du fichier test...

Tous les fichiers que j'ouvre on la même structure et les mêmes noms de feuilles.

Dans l'exemple plus bas, j'ouvre en boucle tous les fichiers et je copie une sélection de la page P1...

Mes fichiers on des noms page comme P1, P2,P3,P4 etc

J'aimerais donc dans mon fichier test dans la cellule H1 choisir P1, P2 ou autre et que ça soit utilisé pour choisir la bonne feuille de mes fichiers...

En d'autre mot pouvoir sélectionner le nom de la page ou les données doivent être sélectionné

' Macro qui permet de compiler les informations contenues dans
' différents fichier pour les regrouper dans un fichier récapitulatif
' GCXL
'-------------------------------------------------------------------------------
Sub Creer_Recapitulatif()
Dim wbRecap As Workbook 'fichier recap
Dim wsRecap As Worksheet 'feuille où on écrit les données
Dim wbSource As Workbook 'fichier à ouvrir
Dim wsSource As Worksheet 'feuille où on cherche les données
Dim vFichiers As Variant 'noms des fichiers
Dim strName As String
Dim i As Integer, k As Integer



' --- Ouvrir boite de dialogue pour sélectionner les fichiers à ouvrir

vFichiers = Selectionner_Fichiers("Sélectionner les fichiers à compiler") 'Appel de Fonction pour ouvrir fichiers


' --- Vérifier qu'au moins un fichier à été sélectionné
If Not IsArray(vFichiers) Then
Debug.Print "Aucun fichier sélectionné."
MsgBox "Erreur! Aucun/Mauvais fichier sélectionné."
Exit Sub
End If
On Error Resume Next

Application.ScreenUpdating = False

' --- Boucle à travers les fichiers
For k = 1 To UBound(vFichiers)
Application.StatusBar = ">> Lecture du fichier #" & k & "/" & UBound(vFichiers)

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' C'est ici qu'on écrit les instructions

Set wbSource = Workbooks.Open(vFichiers(k)) 'on ouvre le fichier

With wsSource
Sheets("P1").Select
Range("a2:q2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows("test.xlsm").Activate 'sélectionne la feuille du transfert
Sheets("Sheet1").Select
Range("c65000").End(xlUp).Offset(1).Select 'recherche la première cellule vide
ActiveSheet.Paste
Application.CutCopyMode = False

wbSource.Close

End With



' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Next k

Application.ScreenUpdating = True
Application.StatusBar = False

End Sub
Function Selectionner_Fichiers(sTitre As String) As Variant
Dim sFiltre As String, bMultiSelect As Boolean

sFiltre = "Fichiers XYZ (.xls)(.xlsm), *.xls*"
bMultiSelect = True 'Permet de choisir plusieurs fichiers à la fois
ChDrive "C"
ChDir "C:\temp"
Selectionner_Fichiers = Application.GetOpenFilename(Filefilter:=sFiltre, Title:=sTitre, MultiSelect:=bMultiSelect)
End Function
 

Pièces jointes

  • test.zip
    25.6 KB · Affichages: 17
  • test.zip
    25.6 KB · Affichages: 16
  • test.zip
    25.6 KB · Affichages: 16

chemist

XLDnaute Junior
Re : Sélectionner une feuille d'un classeur avec nom dans une cellulle d'un autre cla

Bonjour

comme je l'avais dit tout est parfait mais maintenant j'aimerais ajouter une variante soit d'aller chercher des données sur plusieurs pages des fichiers que je sélectionne.

Donc en résumé, j'aimerais ouvrier un fichier et aller chercher une sélection de la page 1 et la copier dans mon fichier recap sur la feuille data1 et prendre une sélection de la page 2 et copier sur ma page data2 etc. et ce pour plus d'un fichier.

Revoici ma macro et des fichiers test

Sub Creer_Recapitulatif()

Dim wbSource As Workbook 'fichier à ouvrir
Dim vFichiers As Variant 'noms des fichiers
Dim k As Integer
Dim Page As String
Dim LigneFin As Long, LigneCible As Long



' --- Ouvrir boite de dialogue pour sélectionner les fichiers à ouvrir

vFichiers = Selectionner_Fichiers("Sélectionner les fichiers à compiler") 'Appel de Fonction pour ouvrir fichiers


' --- Vérifier qu'au moins un fichier à été sélectionné
If Not IsArray(vFichiers) Then
Debug.Print "Aucun fichier sélectionné."
MsgBox "Erreur! Aucun/Mauvais fichier sélectionné."
Exit Sub
End If
'On Error Resume Next

Application.ScreenUpdating = False

'Lecture du nom de la page demandée
Page = ThisWorkbook.Sheets("DATA1").Range("H1")

'Effacer avant de débuter
Sheets("DATA1").Select
Range("C10:w2890").Select
Selection.ClearContents

' --- Boucle à travers les fichiers
For k = 1 To UBound(vFichiers)
Application.StatusBar = ">> Lecture du fichier #" & k & "/" & UBound(vFichiers)

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' C'est ici qu'on écrit les instructions

Set wbSource = Workbooks.Open(vFichiers(k)) 'on ouvre le fichier
On Error Resume Next
With wbSource.Sheets(Page)
If Err.Number <> 0 Then MsgBox " Feuille " & Page & " inexistante dans le classeur " & vFichiers(k): GoTo Suite
On Error GoTo 0
LigneFin = .Range("a" & Rows.Count & ":u" & Rows.Count).End(xlUp).Row 'Derniere ligne à copier
LigneCible = ThisWorkbook.Sheets("DATA1").Range("c" & Rows.Count).End(xlUp).Row + 1 'recherche la première cellule vide
.Range("a3:u" & LigneFin).Copy Destination:=ThisWorkbook.Sheets("DATA1").Range("c" & LigneCible)

End With

Suite:
wbSource.Close False
Set wbSource = Nothing

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Next k
Application.ScreenUpdating = True
Application.StatusBar = False

End Sub
Function Selectionner_Fichiers(sTitre As String) As Variant
Dim sFiltre As String, bMultiSelect As Boolean

sFiltre = "Fichiers XYZ (.xls)(.xlsm), *.xls*"
bMultiSelect = True 'Permet de choisir plusieurs fichiers à la fois
ChDrive "c"
ChDir "c:\temp"
Selectionner_Fichiers = Application.GetOpenFilename(Filefilter:=sFiltre, Title:=sTitre, MultiSelect:=bMultiSelect)
End Function
 

Pièces jointes

  • recap.zip
    103.3 KB · Affichages: 16
  • recap.zip
    103.3 KB · Affichages: 16
  • recap.zip
    103.3 KB · Affichages: 19

chemist

XLDnaute Junior
Re : Sélectionner une feuille d'un classeur avec nom dans une cellulle d'un autre cla

Bonjour j'ai trouvé, je ne sais pas si c'est une bonne façon mais ça fonctionne
j'ai ajouté

Dim Page2 As String
Page2 = ThisWorkbook.Sheets("DATA2").Range("H1")



im wbSource As Workbook 'fichier à ouvrir
Dim vFichiers As Variant 'noms des fichiers
Dim k As Integer
Dim Page As String
Dim Page2 As String
Dim LigneFin As Long, LigneCible As Long



' --- Ouvrir boite de dialogue pour sélectionner les fichiers à ouvrir

vFichiers = Selectionner_Fichiers("Sélectionner les fichiers à compiler") 'Appel de Fonction pour ouvrir fichiers


' --- Vérifier qu'au moins un fichier à été sélectionné
If Not IsArray(vFichiers) Then
Debug.Print "Aucun fichier sélectionné."
MsgBox "Erreur! Aucun/Mauvais fichier sélectionné."
Exit Sub
End If
'On Error Resume Next

Application.ScreenUpdating = False

'Lecture du nom de la page demandée
Page = ThisWorkbook.Sheets("DATA1").Range("H1")
Page2 = ThisWorkbook.Sheets("DATA2").Range("H1")

'Effacer avant de débuter
Sheets(Array("Data1", "Data2", "Data3")).Select
Sheets("Data1").Activate
Range("C10:W10").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents

' --- Boucle à travers les fichiers
For k = 1 To UBound(vFichiers)
Application.StatusBar = ">> Lecture du fichier #" & k & "/" & UBound(vFichiers)

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' C'est ici qu'on écrit les instructions

Set wbSource = Workbooks.Open(vFichiers(k)) 'on ouvre le fichier
On Error Resume Next
With wbSource.Sheets(Page)
If Err.Number <> 0 Then MsgBox " Feuille " & Page & " inexistante dans le classeur " & vFichiers(k): GoTo Suite
On Error GoTo 0
LigneFin = .Range("a" & Rows.Count & ":u" & Rows.Count).End(xlUp).Row 'Derniere ligne à copier
LigneCible = ThisWorkbook.Sheets("DATA1").Range("c" & Rows.Count).End(xlUp).Row + 1 'recherche la première cellule vide
.Range("a3:u" & LigneFin).Copy Destination:=ThisWorkbook.Sheets("DATA1").Range("c" & LigneCible)
End With
With wbSource.Sheets(Page2)
LigneFin = .Range("a" & Rows.Count & ":u" & Rows.Count).End(xlUp).Row 'Derniere ligne à copier
LigneCible = ThisWorkbook.Sheets("DATA2").Range("c" & Rows.Count).End(xlUp).Row + 1 'recherche la première cellule vide
.Range("a3:u" & LigneFin).Copy Destination:=ThisWorkbook.Sheets("DATA2").Range("c" & LigneCible)
End With

Suite:
wbSource.Close False
Set wbSource = Nothing

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Next k
Application.ScreenUpdating = True
Application.StatusBar = False

End Sub
Function Selectionner_Fichiers(sTitre As String) As Variant
Dim sFiltre As String, bMultiSelect As Boolean

sFiltre = "Fichiers XYZ (.xls)(.xlsm), *.xls*"
bMultiSelect = True 'Permet de choisir plusieurs fichiers à la fois
ChDrive "c"
ChDir "c:\temp"
Selectionner_Fichiers = Application.GetOpenFilename(Filefilter:=sFiltre, Title:=sTitre, MultiSelect:=bMultiSelect)
End Function
 
Dernière édition:

Discussions similaires

Réponses
7
Affichages
485

Statistiques des forums

Discussions
311 709
Messages
2 081 768
Membres
101 816
dernier inscrit
Jfrcs