XL 2016 Copier Coller données avec VBA dernière cellules vide

Anto35200

XLDnaute Occasionnel
Bonjour,
A partir du fichier « extraction », je souhaiterai pouvoir copier, avec une macro, à partir de la ligne 2 jusqu’à la dernière ligne vide, et le coller dans le fichier « BD » à la suite des données déjà présentes, c’est-à dire à la ligne 13.
En gros, je dois au quotidien, faire une extraction des données et le copier dans le fichier BD.

En vous remerciant de votre aide que vous pourrez m'apporter.
 

Pièces jointes

  • Extraction.xlsx
    9.8 KB · Affichages: 7
  • BD.xlsx
    10 KB · Affichages: 6
Solution
Bonjour,

On me snobe mais je m'en fiche :
VB:
Sub Copier()
Dim fichier1$, fichier2$, c As Range
fichier1 = ThisWorkbook.Path & "\BD.xlsx"
fichier2 = ThisWorkbook.Path & "\Extraction.xlsx"
If Dir(fichier1) = "" Then MsgBox fichier1 & " introuvable !": Exit Sub
If Dir(fichier2) = "" Then MsgBox fichier2 & " introuvable !": Exit Sub
Application.ScreenUpdating = False
Workbooks.Open fichier1 'ouverture du 1er fichier
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
Set c = Cells.Find("*", , xlValues, , xlByRows, xlPrevious)
If c Is Nothing Then Set c = [A2] Else Set c = Cells(c.Row + 1, 1)
Workbooks.Open fichier2 'ouverture du 2ème fichier
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille...

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Anto,
Un essai en PJ avec :
VB:
Sub Extraction()
Dim Wkb, Tablo, DL
Application.ScreenUpdating = False
Set Wkb = GetObject(ThisWorkbook.Path & "\Extraction.xlsx") ' Si les 2 fichiers sont dans le même dossier
Tablo = Wkb.Sheets("Sheet").[A1].CurrentRegion              ' Transfert de la plage à copier dans tableau
ActiveSheet.ShowAllData                                     ' Suppression des filtres
DL = 1 + Range("A65500").End(xlUp).Row                      ' Ligne où écrire
Cells(DL, "A").Resize(UBound(Tablo, 1), UBound(Tablo, 2)) = Tablo   ' Transfert du tableau
Rows(DL).Delete Shift:=xlUp                                 ' Supppression ligne des titres
Wkb.Close SaveChanges:=False                                ' Fermeture fichier de lecture
End Sub
 

Pièces jointes

  • BD.xlsm
    17.8 KB · Affichages: 5
Dernière édition:

sylvanu

XLDnaute Barbatruc
Supporter XLD
Il eût été plus sain de continuer sur ce post.
Car sur mon PC ça marche :
Test2.gif

Là où un bug peut se produire c'est si aucun filtre n'est en place, dans ce cas il faut supprimer la ligne :
ActiveSheet.ShowAllData

Dans votre cas où est ce que cela buggue ?
 

job75

XLDnaute Barbatruc
Bon supprimer les doublons ne vous intéresse probablement pas.

Puisque les données du fichier "Extraction" sont déjà dans le fichier "BD".

Alors vous pouvez utiliser cette macro :
VB:
Sub Copier()
Dim fichier$, c As Range
fichier = ThisWorkbook.Path & "\Extraction.xlsx"
If Dir(fichier) = "" Then MsgBox fichier & " introuvable !": Exit Sub
Application.ScreenUpdating = False
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
Set c = Cells.Find("*", , xlValues, , xlByRows, xlPrevious)
If c Is Nothing Then Set c = [A2] Else Set c = Cells(c.Row + 1, 1)
Workbooks.Open fichier
ActiveSheet.UsedRange.Offset(1).Copy c
ActiveWorkbook.Close False
End Sub
 

Pièces jointes

  • BD.xlsm
    19.4 KB · Affichages: 0
  • Extraction.xlsx
    9.8 KB · Affichages: 2

Anto35200

XLDnaute Occasionnel
Bonjour Sylvanu,

Effectivement, en supprimant la ligne ActiveSheet.ShowAllData, çà fonctionne.
Comment je peux lancer cette macro depuis un autre fichier ?
C'est-à-dire, il y aura un fichier avec la macro qui copiera les données du fichier Extraction dans le fichier BD.
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Anto,
Si je comprend bien, il y a un "FichierMaitre" qui a une macro.
Cette macro prend les données du fichier Extraction, les écrit dans BD, et sort. C'est bien ça ?
Si oui, essayez cette PJ :
VB:
Sub Extraction()
Dim Wkb, Tablo, DL
Application.ScreenUpdating = False
' Copie des données du fichier source
Set Wkb1 = GetObject(ThisWorkbook.Path & "\Extraction.xlsx") ' Si les 2 fichiers sont dans le même dossier
Tablo = Wkb1.Sheets("Sheet").[A1].CurrentRegion              ' Transfert de la plage à copier dans tableau
Wkb1.Close SaveChanges:=False                                ' Fermeture fichier de lecture
' Ecriture dans fichier destination
Workbooks.Open ThisWorkbook.Path & "\BD.xlsx"               ' Ouverture fichier pour écriture
With Sheets("Sheet")
    If .FilterMode Then .ShowAllData                        ' Suppression des filtres
    DL = 1 + .Range("A65500").End(xlUp).Row                 ' Ligne où écrire
    .Cells(DL, "A").Resize(UBound(Tablo, 1), UBound(Tablo, 2)) = Tablo   ' Transfert du tableau
    .Rows(DL).Delete Shift:=xlUp                            ' Supppression ligne des titres
End With
ActiveWorkbook.Save                                         ' Sauvegarde
ActiveWorkbook.Close                                        ' Fermeture , à supprimer si on veut garder le fichier ouvert
' A supprimer, juste pour test
[C8] = "Nombre de lignes copiées :":    [D8] = UBound(Tablo) - 1
[C9] = "Nombre de lignes BD avant :":   [D9] = DL - 1
[C10] = "Nombre de lignes BD après :":  [D10] = [D8] + [D9]
End Sub
La fin est juste pour le test. Inutile et peut être supprimée.
La ligne "ActiveWorkbook.Close" est à supprimer si vous voulez garder le fichier BD ouvert à la fin.
A noter, comme le dit Job, que la macro copiera à chaque fois qu'on clique sur le bouton. Question : Doit on supprimer les doublons ou certaines lignes peuvent être "naturellement" doublonnées ?
 

Pièces jointes

  • FichierMaitre.xlsm
    17.9 KB · Affichages: 1

job75

XLDnaute Barbatruc
Bonjour,

On me snobe mais je m'en fiche :
VB:
Sub Copier()
Dim fichier1$, fichier2$, c As Range
fichier1 = ThisWorkbook.Path & "\BD.xlsx"
fichier2 = ThisWorkbook.Path & "\Extraction.xlsx"
If Dir(fichier1) = "" Then MsgBox fichier1 & " introuvable !": Exit Sub
If Dir(fichier2) = "" Then MsgBox fichier2 & " introuvable !": Exit Sub
Application.ScreenUpdating = False
Workbooks.Open fichier1 'ouverture du 1er fichier
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
Set c = Cells.Find("*", , xlValues, , xlByRows, xlPrevious)
If c Is Nothing Then Set c = [A2] Else Set c = Cells(c.Row + 1, 1)
Workbooks.Open fichier2 'ouverture du 2ème fichier
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
ActiveSheet.UsedRange.Offset(1).Copy c 'copier-coller
ActiveWorkbook.Close False 'fermeture du 2ème fichier
c.Parent.Parent.Close True 'fermeture du 1er fichier après enregistrement
MsgBox Dir(fichier2) & " a été copié vers " & Dir(fichier1)
End Sub
A+
 

Pièces jointes

  • Fichier pilote.xlsm
    19.6 KB · Affichages: 2
  • BD.xlsx
    11.1 KB · Affichages: 1
  • Extraction.xlsx
    9.8 KB · Affichages: 1

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Job,
On me snobe mais je m'en fiche
Je ne pense pas, mais Anto a une façon bien particulière de communiquer.
Il pose une question, il a une réponse (boguée) donc il s'en va sans même répondre avant qu'on lui pose la question et refait un post. (Lien) qui n'aboutit pas non plus.
Alors il revient ici, repose une question sans même avoir lu vos propositions.
Peut être finira t-il par converger. :)
 

Discussions similaires

Réponses
3
Affichages
108

Statistiques des forums

Discussions
313 209
Messages
2 096 239
Membres
106 541
dernier inscrit
edf