VBA transfert des données d'un classeur vers d'un autre

Le 22/08/2015 à 01:11

Bonsoir,

est ce que vous pourriez m'aider à corriger la macro jointe :

Je voudrai importer automatiquement la totalité des données contenues dans la feuille 1 de 2 classeurs source différents dans les 2 premiers onglets d'un 3ème classeur de destination. c'est tout bêtement un copier coller de la totalité des données mais sans dupliquer la feuille.

les fichiers sources sont des fichiers brut d'extraction sauvegardés sous des noms différents en fonction des dates d'extraction. Ils comportent des données différentes. Donc l'idéal serait que la macro puisse donner le choix pour ouvrir le fichier source dans les répertoires de travail, effectuer le copier coller dans l'onglet correspondant du fichier destinataire et fermer le fichier source. Ces opérations peuvent se répèter plusieurs fois dans l'année et c'est pourquoi la notion de la dernière ligne est importante pour rajouter en cours de route les données nouvelles en dessous de celles déjà transférées.

Le fichier destinataire comporte plusieurs onglets dont les 2 premiers reprennent chacun les données des 2 fichiers sources ; ces onglets sont nommés expressément feuille1(ALIFM) feuille2(GRC), les données doivent subir ensuite un traitement pour être compilées dans un 3ème onglet.

J'ai essayé de bricoler la macro qui suit : le copier coller ne se fait pas correctement ni dans la feuille1 de l'onglet de destination ni dans la feuille2 si je change le numéro de la feuille dans la macro. Je ne crois pas que la syntaxe pour copier coller toutes les données d'une feuille que j'ai employée soit la bonne ? je voudrai également suprimer la variable k qui sert à ouvrir le fichier suivant.

Merci d'avance pour votre aide.

Sub trasfert_fichiers()

Dim wsRecap As Worksheet 'feuille où on écrit les données fichier destinataire

Dim wbSource As Workbook 'fichier source à ouvrir

Dim wsSource As Worksheet 'feuille du fichier source où on cherche les données

Dim DernLign As Integer 'ligne où on écrit les données

Dim vFichiers As Variant 'noms des fichiers

Dim i As Integer, k As Integer ' ?

Dim rgRecap As Range 'plage où on copie les données

Set wbRecap = ThisWorkbook 'Fichier récapitulatif

Set wsRecap = wbRecap.Sheets(1) 'on écrit dans la feuille 1 du fichier récapitulatif

' --- 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)

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

' les instructions

Set wbSource = Workbooks.Open(vFichiers(k)) 'ouverture du fichier source feuille1

Set wsSource = wbSource.Sheets(1) ' copie des données de la feuille1

DernLign = wbRecap.Sheets(1).Range("A60000").End(xlUp).Row + 1 'ligne pour écrire le log des fichiers compilés

' - On copie les données vers le fichier Recapitulatif; à adapter

Set rgRecap = wsRecap.Range("A65000").End(xlUp).Offset(0, 0)

rgRecap = Date

With wsSource

rgRecap(Cells) = .Range(Cells) ' CA NE MARCHE PAS ?

End With

wbSource.Close 'fermeture fichier du fichier source

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

Selectionner_Fichiers = Application.GetOpenFilename(Filefilter:=sFiltre, Title:=sTitre, MultiSelect:=bMultiSelect)

End Function

Le 22/08/2015 à 01:46

Hello,

Sauf erreur de ma part, il manque une composante essentielle : les colonnes.

Sinon :

 - On copie les données vers le fichier Recapitulatif; à adapter
Set rgRecap = wsRecap.Range("A65000").End(xlUp).Offset(0, 0)
rgRecap = Date
With wsSource
rgRecap(Cells) = .Range(Cells) ' CA NE MARCHE PAS ?

Tu affectes 1 cellule à rgRecap, puis tu lui affectes la date du jour (on passe sur le offset qui décale de 0 ligne et 0 colonne ^^) ;

et rgRecap(Cells) n'est pas une instruction valide. Cells doit etre suivi de l'index de ligne et de l'index de colonne : Cells(Row, Col). C'est l'équivalent de L1C1.

As-tu des intitulés de colonnes ?

Il te faudrait plus un truc du genre

With wsSurce
lR(1)= .UsedRange.Rows.Count
lC(1) = .UsedRange.Columns.Count 
oRng = .Range(Cells(1, 1), Cells(lR(1), lC(1))).Value
End with

With wsRecap
lR(0) = .UsedRange.Rows.Count
End with
For K = 1 to Ubound(oRng, 1)
For J = 1 to Ubound(orng, 2)

wsRecap.Cells(lR(0) + K, J) = oRng(K, J)
Next K
Next J

A (re)voir au réveil (autant pour toi que pour moi :] )

Le 24/08/2015 à 09:01

Bonjour,

Merci beaucoup pour ta réponse.

J'ai remplacé les instructions concernant le copier coller, (j'ai seulement remplacé la variable k déjà utilisée dans la macro par m )

mais cela ne marche toujours pas avec le message d'erreur suivant :

SUB OU FONCTION NON DEFINI et cela s'arrête sur lR(1)

oui j'ai des intitulés de colonnes sur la première ligne

Voici la macro corrigée comme indiquée

Sub trasfert_fichiers()

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 DernLign As Integer 'ligne où on écrit les données

Dim vFichiers As Variant 'noms des fichiers

Dim i As Integer, k As Integer

Dim rgRecap As Range 'plage où on copie les données

Set wbRecap = ThisWorkbook 'Fichier récapitulatif

Set wsRecap = wbRecap.Sheets(1) 'on écrit dans la feuille 1 du fichier récapitulatif

' --- 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

Set wsSource = wbSource.Sheets(1) 'On copie les données de la feuille 1

DernLign = wbRecap.Sheets(1).Range("A60000").End(xlUp).Row + 1 'ligne pour écrire le log des fichiers compilés

' - On copie les données vers le fichier Recapitulatif; à adapter

Set rgRecap = wsRecap.Range("A65000").End(xlUp).Offset(0, 0)

rgRecap = Time

With wsSource

lR(1) = .UsedRange.Rows.Count

lC(1) = .UsedRange.Columns.Count

oRng = .Range(Cells(1, 1), Cells(lR(1), lC(1))).Value

End With

With wsRecap

lR(0) = .UsedRange.Rows.Count

End With

For L = 1 To UBound(oRng, 1)

For J = 1 To UBound(oRng, 2)

wsRecap.Cells(lR(0) + L, J) = oRng(L, J)

Next L

Next J

End With

wbSource.Close 'fermer fichier

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

Selectionner_Fichiers = Application.GetOpenFilename(Filefilter:=sFiltre, Title:=sTitre, MultiSelect:=bMultiSelect)

End Function

Le 24/08/2015 à 10:04

Un code indenté et balisé ([ code=vb][ /code] est bien plus facile à lire pour les helpeurs et lecteurs

Je regarde ça.

EDIT : Ok c'est simple, tu n'as pas déclaré les variables lR() et lC().

Prends l'habitude de placer "Option explicit" en début de module, hors de la procédure, pour t'obliger à déclarer.

Ca devrait mieux marcher comme ça

Sub trasfert_fichiers()

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 lR(1) As Integer, lC(1) as integer 'ligne où on écrit les données
Dim vFichiers As Variant 'noms des fichiers
Dim i As Integer, k As Integer
Dim rgRecap As Range 'plage où on copie les données

Set wbRecap = ThisWorkbook 'Fichier récapitulatif
Set wsRecap = wbRecap.Sheets(1) 'on écrit dans la feuille 1 du fichier récapitulatif

' --- 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
Set wsSource = wbSource.Sheets(1) 'On copie les données de la feuille 1
DernLign = wbRecap.Sheets(1).Range("A60000").End(xlUp).Row + 1 'ligne pour écrire le log des fichiers compilés

' - On copie les données vers le fichier Recapitulatif; à adapter
Set rgRecap = wsRecap.Range("A65000").End(xlUp).Offset(0, 0)
rgRecap = Time

With wsSource
lR(1) = .UsedRange.Rows.Count
lC(1) = .UsedRange.Columns.Count
oRng = .Range(Cells(1, 1), Cells(lR(1), lC(1))).Value
End With

With wsRecap
lR(0) = .UsedRange.Rows.Count
End With
For L = 1 To UBound(oRng, 1)
For J = 1 To UBound(oRng, 2)

wsRecap.Cells(lR(0) + L, J) = oRng(L, J)
Next L
Next J

End With

wbSource.Close 'fermer fichier
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
Selectionner_Fichiers = Application.GetOpenFilename(Filefilter:=sFiltre, Title:=sTitre, MultiSelect:=bMultiSelect)
End Function

Le 24/08/2015 à 11:05

Merci de répondre aussi vite mais désolée ça ne marche toujours pas :

J'ai recopié la macro, j'ai défini les variables L et J et j'ai le message d'erreur suivant :

le surseur se positione sur :

wsRecap.Cells(lR(0) + L, J) = oRng(L, J)

Next L

Next J

macro :

Sub trasfert_fichiers()

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 lR(1) As Integer, lC(1) As Integer 'ligne où on écrit les données (ou l'équivalent : Dim lR(1)%, lC(1)%)

Dim L As Integer, J As Integer

Dim vFichiers As Variant 'noms des fichiers

Dim i As Integer, k As Integer

Dim rgRecap As Range 'plage où on copie les données

Set wbRecap = ThisWorkbook 'Fichier récapitulatif

Set wsRecap = wbRecap.Sheets(1) 'on écrit dans la feuille 1 du fichier récapitulatif

' --- 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

Set wsSource = wbSource.Sheets(1) 'On copie les données de la feuille 1

DernLign = wbRecap.Sheets(1).Range("A60000").End(xlUp).Row + 1 'ligne pour écrire le log des fichiers compilés

' - On copie les données vers le fichier Recapitulatif; à adapter

Set rgRecap = wsRecap.Range("A65000").End(xlUp).Offset(0, 0)

rgRecap = Time

With wsSource

lR(1) = .UsedRange.Rows.Count

lC(1) = .UsedRange.Columns.Count

oRng = .Range(Cells(1, 1), Cells(lR(1), lC(1))).Value

End With

With wsRecap

lR(0) = .UsedRange.Rows.Count

End With

For L = 1 To UBound(oRng, 1)

For J = 1 To UBound(oRng, 2)

wsRecap.Cells(lR(0) + L, J) = oRng(L, J)

Next L

Next J

End With

wbSource.Close 'fermer fichier

Set wbSource = Nothing

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Next k

Application.ScreenUpdating = True

Application.StatusBar = False

End Sub

Le 24/08/2015 à 11:10

Un code indenté et balisé ([ code=vb][ /code] est bien plus facile à lire pour les helpeurs et lecteurs

Quel est le message d'erreur ?

Le 24/08/2015 à 13:47

OUPS j'ai oublié de le mentionner :

ERREUR DE COMPILATION référence de variable de contrôle incorrecte dans next et NEXT L est mis en surbrillance.

Cordialement

Le 24/08/2015 à 13:49

Inverse Next L et Next J

Le 25/08/2015 à 09:59

Bonjour,

Désolée, mais rien ne se passe ??

j'ai inversé l'ordre des variables dans les next et j'ai suprimé un End with car sans with. Je ne comprends pas pourquoi cela ne fonctionne pas.

Cordialement

Sub transfert_fichiers()

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 lR(1) As Integer, lC(1) As Integer 'ligne où on écrit les données

Dim vFichiers As Variant 'noms des fichiers

Dim i As Integer, k As Integer

Dim L As Integer, J As Integer

Dim rgRecap As Range 'plage où on copie les données

Set wbRecap = ThisWorkbook 'Fichier récapitulatif

Set wsRecap = wbRecap.Sheets(1) 'on écrit dans la feuille 1 du fichier récapitulatif

' --- 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

Set wsSource = wbSource.Sheets(1) 'On copie les données de la feuille 1

DernLign = wbRecap.Sheets(1).Range("A60000").End(xlUp).Row + 1 'ligne pour écrire le log des fichiers compilés

' - On copie les données vers le fichier Recapitulatif; à adapter

Set rgRecap = wsRecap.Range("A65000").End(xlUp).Offset(0, 0)

rgRecap = Time

With wsSource

lR(1) = .UsedRange.Rows.Count

lC(1) = .UsedRange.Columns.Count

oRng = .Range(Cells(1, 1), Cells(lR(1), lC(1))).Value

End With

With wsRecap

lR(0) = .UsedRange.Rows.Count

End With

For L = 1 To UBound(oRng, 1)

For J = 1 To UBound(oRng, 2)

wsRecap.Cells(lR(0) + L, J) = oRng(L, J)

Next J

Next L

wbSource.Close 'fermer fichier

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

Selectionner_Fichiers = Application.GetOpenFilename(Filefilter:=sFiltre, Title:=sTitre, MultiSelect:=bMultiSelect)

End Function

Le 25/08/2015 à 10:07

Stop. Je ne vais pas te répéter à chaque message de baliser ton code.

Jusque là, débrouille toi.

Rechercher des sujets similaires à "vba transfert donnees classeur"