Importer différentes feuil dans un seul classeur
Bonjour A toutes et tous
Je cherche une macro qui permet de copier :
- Plusieurs onglets / feuilles de différents classeurs X vers un seul classeur A
Exemple
Classeur A copier : Feuil 1 / Feuil 2 / Feuil 3 / ….
Classeur X1 (peu contenir plusieurs feuil) : Feuil 1 chemin : C:\....\ Classeur X1
Classeur X2 (peu contenir plusieurs feuil) : Feuil 2 chemin : C:\....\ Classeur X2
Classeur X3 (peu contenir plusieurs feuil) : Feuil 3 chemin : C:\....\ Classeur X3
Classeur X4 (peu contenir plusieurs feuil) : Feuil 4 chemin : C:\....\ Classeur X4
….Est-ce que c’est clair pour vous ou pas ? Si oui, merci d’avance pour votre soutien et vos solutions
Salutations @ vous
Bonjour,
Une piste à adapter :
Sub Test()
Dim Cls As Workbook
Dim Tbl() As String
Dim Chemin As String
Dim I As Integer
With Application.FileDialog(4)
If .Show = -1 Then Chemin = .SelectedItems(1) Else Exit Sub
End With
Tbl = Fichiers(Chemin)
If Not (Not Tbl()) Then
For I = 1 To UBound(Tbl)
Set Cls = Workbooks.Open(Tbl(I))
On Error Resume Next 'évite l'erreur due à la feuille inexistante
'adapter les noms des feuilles à copier
Cls.Worksheets(Array("Feuil1", "Feuil2")).Copy ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Cls.Close False
Next I
End If
End Sub
Function Fichiers(Chemin As String) As String()
Dim TblFichiers() As String
Dim Fichier As String
Dim I As Integer
Fichier = Dir(Chemin & "\*xlsx") 'seulement le fichiers .xlsx (donc sans macro !)
Do While (Len(Fichier) > 0)
I = I + 1: ReDim Preserve TblFichiers(1 To I)
TblFichiers(I) = Chemin & "\" & Fichier
Fichier = Dir()
Loop
Fichiers = TblFichiers()
End Function
Bonjour Theze ,
Je pense qu'il est plus simple pour toi d'avoir un exemple, non ... je viens de tester mais je ne pense pas que c'est ce que je voulais avoir comme résultat ...
Dans le fichier "Test Flotte" je rassemble plusieurs feuil/onglet venant de plusieurs onglet d'autre fichiers ...
Ce que je voulais faire, c'est de mettre à jour :
L'onglet JTN du fichier Test Flotte soit mis à jour depuis l'onglet "actuel" du fichier JTN
L'onglet ASA du fichier Test Flotte soit mis à jour depuis l'onglet "actuel" du fichier ASA
Par la suite et avec une autre macro je rassemble ces onglet dans un seul, comme ici dans l'exemple S14 ...
Opération (mise à jours) à faire tous les jours et plusieurs fois dans la journée ...
Est-ce que c'est plus clair pour toi ? en tt cas j'attends avec impatience ton retour et celui des autres membres du forum ... car là je suis vraiment bloqué ...
Un grand merci pour votre aide les amis
@+++
Any Help :,( ... j'attends vraiment votre soutien les amis !
Bonjour,
Désolé mais quand je lis ta demande :
Je cherche une macro qui permet de copier :
- Plusieurs onglets / feuilles de différents classeurs X vers un seul classeur A
Exemple
Classeur A copier : Feuil 1 / Feuil 2 / Feuil 3 / ….
Classeur X1 (peu contenir plusieurs feuil) : Feuil 1 chemin : C:\....\ Classeur X1
Classeur X2 (peu contenir plusieurs feuil) : Feuil 2 chemin : C:\....\ Classeur X2
Classeur X3 (peu contenir plusieurs feuil) : Feuil 3 chemin : C:\....\ Classeur X3
Classeur X4 (peu contenir plusieurs feuil) : Feuil 4 chemin : C:\....\ Classeur X4
pour moi, le code que je t'ai donné correspond !
Bon, le code ci-dessous est à mettre dans un module standard du classeur "Test Flotte" et enregistrer en .xlsm. Le code défini la plage sur toute la feuille à partir de A3 (les feuilles "Actuel" des autres classeurs !) et mets les valeurs dans les feuilles correspondantes en ayant au préalable vidé la feuille de ses précédentes valeurs. Si les valeurs des feuilles doivent être conservées, fait le moi savoir :
Sub MiseAJour()
Dim Cls As Workbook
Dim Plage As Range
On Error Resume Next
Set Cls = Workbooks("ASA.xlsx")
If Err.Number <> 0 Then MsgBox "Le fichier ASA.xlsx n'est pas ouvert !": Exit Sub
Set Plage = DefPlage(Cls.Worksheets("Actuel"), 3, 1)
With ThisWorkbook.Worksheets("ASA")
.Range(.Cells(3, 1), .Cells(Rows.Count, Plage.Columns.Count)).ClearContents
.Range(.Cells(3, 1), .Cells(Plage.Rows.Count, Plage.Columns.Count)).Value = Plage.Value
End With
Set Cls = Workbooks("JTN.xlsx")
If Err.Number <> 0 Then MsgBox "Le fichier JTN.xlsx n'est pas ouvert !": Exit Sub
Set Plage = DefPlage(Cls.Worksheets("Actuel"), 3, 1)
With ThisWorkbook.Worksheets("JTN")
.Range(.Cells(3, 1), .Cells(Rows.Count, Plage.Columns.Count)).ClearContents
.Range(.Cells(3, 1), .Cells(Plage.Rows.Count, Plage.Columns.Count)).Value = Plage.Value
End With
End Sub
Function DefPlage(Fe As Worksheet, Optional L As Long = 1, Optional C As Long = 1) As Range
On Error GoTo Fin
With Fe
Set DefPlage = .Range(.Cells(L, C), _
.Cells(.Cells.Find("*", .[A1], -4123, , _
1, 2).Row, .Cells.Find("*", .[A1], -4123, , _
2, 2).Column))
End With
Exit Function
Fin:
Set DefPlage = Nothing
End Function
Re,
petite précision, les classeurs doivent être ouverts avant le lancement du code sinon, tu auras un message et ça mettra fin à la procédure !
Bonjour Theze,
Il n'y a pas un moyen de faire ouvrir le fichier automatiquement et le fermer une fois la MAj est faite ?
La macro prends uniquement les valeur jusq'à la ligne 13 et pas ce qui est au dessous ?
Merci en tout cas pour ton aide
@+
Re,
petite précision, les classeurs doivent être ouverts avant le lancement du code sinon, tu auras un message et ça mettra fin à la procédure !
Re,
La macro prends uniquement les valeur jusq'à la ligne 13 et pas ce qui est au dessous ?
Oups, désolé, j'ai oublié de prendre en compte le décalage dû aux lignes d'entêtes
Il n'y a pas un moyen de faire ouvrir le fichier automatiquement et le fermer une fois la MAj est faite ?
Donc voici, les fichiers sont sensés être dans le même dossier que le fichier "Test Flotte" :
Sub MiseAJour()
Dim Cls As Workbook
Dim Plage As Range
On Error Resume Next
Set Cls = Workbooks.Open(ThisWorkbook.Path & "\" & "ASA.xlsx")
If Err.Number <> 0 Then MsgBox "Erreur lors de l'ouverture !": Exit Sub
Set Plage = DefPlage(Cls.Worksheets("Actuel"), 3, 1)
With ThisWorkbook.Worksheets("ASA")
.Range(.Cells(3, 1), .Cells(Rows.Count, Plage.Columns.Count)).ClearContents
.Range(.Cells(3, 1), .Cells(Plage.Rows.Count + 2, Plage.Columns.Count)).Value = Plage.Value
End With
Cls.Close False
Set Cls = Workbooks.Open(ThisWorkbook.Path & "\" & "JTN.xlsx")
If Err.Number <> 0 Then MsgBox "Le fichier JTN.xlsx n'est pas ouvert !": Exit Sub
Set Plage = DefPlage(Cls.Worksheets("Actuel"), 3, 1)
With ThisWorkbook.Worksheets("JTN")
.Range(.Cells(3, 1), .Cells(Rows.Count, Plage.Columns.Count)).ClearContents
.Range(.Cells(3, 1), .Cells(Plage.Rows.Count + 2, Plage.Columns.Count)).Value = Plage.Value
End With
Cls.Close False
End Sub
J'ai un bug disant :
Sub ou fonction non definie !
DefPlage ... non ?
Merci pour ton retour
Re,
La macro prends uniquement les valeur jusq'à la ligne 13 et pas ce qui est au dessous ?
Oups, désolé, j'ai oublié de prendre en compte le décalage dû aux lignes d'entêtes
Il n'y a pas un moyen de faire ouvrir le fichier automatiquement et le fermer une fois la MAj est faite ?
Donc voici, les fichiers sont sensés être dans le même dossier que le fichier "Test Flotte" :
Sub MiseAJour() Dim Cls As Workbook Dim Plage As Range On Error Resume Next Set Cls = Workbooks.Open(ThisWorkbook.Path & "\" & "ASA.xlsx") If Err.Number <> 0 Then MsgBox "Erreur lors de l'ouverture !": Exit Sub Set Plage = DefPlage(Cls.Worksheets("Actuel"), 3, 1) With ThisWorkbook.Worksheets("ASA") .Range(.Cells(3, 1), .Cells(Rows.Count, Plage.Columns.Count)).ClearContents .Range(.Cells(3, 1), .Cells(Plage.Rows.Count + 2, Plage.Columns.Count)).Value = Plage.Value End With Cls.Close False Set Cls = Workbooks.Open(ThisWorkbook.Path & "\" & "JTN.xlsx") If Err.Number <> 0 Then MsgBox "Le fichier JTN.xlsx n'est pas ouvert !": Exit Sub Set Plage = DefPlage(Cls.Worksheets("Actuel"), 3, 1) With ThisWorkbook.Worksheets("JTN") .Range(.Cells(3, 1), .Cells(Rows.Count, Plage.Columns.Count)).ClearContents .Range(.Cells(3, 1), .Cells(Plage.Rows.Count + 2, Plage.Columns.Count)).Value = Plage.Value End With Cls.Close False End Sub
Bonjour,
Tu as supprimé tout le code pour le remplacer par celui-ci-dessus mais il te fallait conserver la fonction DefPlage !
Function DefPlage(Fe As Worksheet, Optional L As Long = 1, Optional C As Long = 1) As Range
On Error GoTo Fin
With Fe
Set DefPlage = .Range(.Cells(L, C), _
.Cells(.Cells.Find("*", .[A1], -4123, , _
1, 2).Row, .Cells.Find("*", .[A1], -4123, , _
2, 2).Column))
End With
Exit Function
Fin:
Set DefPlage = Nothing
End Function
Désolé je n'ai pas vraiment compris ... il faut que je rajoute le dernier code ou remplacer le 1 par le derneir
Merci pour ton retour
Bonjour,
Tu as supprimé tout le code pour le remplacer par celui-ci-dessus mais il te fallait conserver la fonction DefPlage !
Function DefPlage(Fe As Worksheet, Optional L As Long = 1, Optional C As Long = 1) As Range On Error GoTo Fin With Fe Set DefPlage = .Range(.Cells(L, C), _ .Cells(.Cells.Find("*", .[A1], -4123, , _ 1, 2).Row, .Cells.Find("*", .[A1], -4123, , _ 2, 2).Column)) End With Exit Function Fin: Set DefPlage = Nothing End Function
Pour que ce soit plus simple, remplaces tout le code que tu as dans le module par le code ci-dessous :
Sub MiseAJour()
Dim Cls As Workbook
Dim Plage As Range
On Error Resume Next
Set Cls = Workbooks.Open(ThisWorkbook.Path & "\" & "ASA.xlsx")
If Err.Number <> 0 Then MsgBox "Erreur lors de l'ouverture !": Exit Sub
Set Plage = DefPlage(Cls.Worksheets("Actuel"), 3, 1)
With ThisWorkbook.Worksheets("ASA")
.Range(.Cells(3, 1), .Cells(Rows.Count, Plage.Columns.Count)).ClearContents
.Range(.Cells(3, 1), .Cells(Plage.Rows.Count + 2, Plage.Columns.Count)).Value = Plage.Value
End With
Cls.Close False
Set Cls = Workbooks.Open(ThisWorkbook.Path & "\" & "JTN.xlsx")
If Err.Number <> 0 Then MsgBox "Le fichier JTN.xlsx n'est pas ouvert !": Exit Sub
Set Plage = DefPlage(Cls.Worksheets("Actuel"), 3, 1)
With ThisWorkbook.Worksheets("JTN")
.Range(.Cells(3, 1), .Cells(Rows.Count, Plage.Columns.Count)).ClearContents
.Range(.Cells(3, 1), .Cells(Plage.Rows.Count + 2, Plage.Columns.Count)).Value = Plage.Value
End With
Cls.Close False
End Sub
Function DefPlage(Fe As Worksheet, Optional L As Long = 1, Optional C As Long = 1) As Range
On Error GoTo Fin
With Fe
Set DefPlage = .Range(.Cells(L, C), _
.Cells(.Cells.Find("*", .[A1], -4123, , _
1, 2).Row, .Cells.Find("*", .[A1], -4123, , _
2, 2).Column))
End With
Exit Function
Fin:
Set DefPlage = Nothing
End Function
ça ne fonctionne pas ...
toujours le message erreur ... puis fermeture ... déception
Bonjour,
Je viens de re-télécharger tes 3 fichiers, coller mon dernier code et fais le test, tout fonctionne très bien !
toujours le message erreur ... puis fermeture ... déception
Avec une explication comme ça, je ne vais pas pouvoir t'aider ! C'est quoi le message d'erreur ?
Les trois classeurs doivent être dans le même dossier (qu'importe le dossier).
Si tu as modifié quelque chose par rapport aux fichiers postés, il faudrait me le faire savoir !
Ce n'est pas grave ... on considère que la problématique est résolue ...
Est-ce que tu peux m'aider sur un autre sujet, stp ?
ci-joint l'exemple :
En faite je veux copier les colonnes dans le fichier destinataire depuis fichier source quand la valeur de la colonne B de ce dernier est egale à "CLEBAT"
Est-ce claire ?
Merci
Bonjour,
Je viens de re-télécharger tes 3 fichiers, coller mon dernier code et fais le test, tout fonctionne très bien !
toujours le message erreur ... puis fermeture ... déception
Avec une explication comme ça, je ne vais pas pouvoir t'aider ! C'est quoi le message d'erreur ?
Les trois classeurs doivent être dans le même dossier (qu'importe le dossier).
Si tu as modifié quelque chose par rapport aux fichiers postés, il faudrait me le faire savoir !