Importer fichiers Excel à la suite VBA
Bonjour à tous,
Je suis débutante en VBA et je cherche à créer une base de données dans un classeur Excel : j'aimerais importer des fichiers Excel (tous le même format) pour former cette base de données. J'ai réussi à créer un bout de code (d'ailleurs grâce à ce forum) me permettant d'importer un fichier, mais lorsque je veux importer un nouveau fichier cela m'écrase les données précédentes. J'aimerais pouvoir les mettre à la suite dès que j'en importe des nouvelles. Si quelqu'un a une idée de ce qu'il faut que je change je suis preneuse!
J'avais pour idée de rajouter une ligne comme ça (mais je ne sais pas où dans mon code) :
derniereLigne = Sheets("feuil1").Range("A65000").End(x1Up).Row
Elle me permettrait de connaître la dernière ligne non vide et donc d'ajouter les nouvelles données à la suite...
Merci de votre aide !
Mon code :
Public Namepatch3 As String
Sub import()
Application.ScreenUpdating = False
Dim Filt As String
Dim IndexFiltre As Integer
Dim NomFichier As Variant
Dim Titre As String
Dim i As Integer
Dim j As Integer
Dim Msg1 As String
Dim ConsoPDC As Workbook
Dim fichier As String
Dim chaine As String
Dim feuille As Variant
Dim Reponse As Integer
Dim Config As Integer
Dim nomClasseur As Variant
Dim vclasseur As Workbook
Dim resum As Workbook
Namepatch3 = ActiveWorkbook.Name
Windows(Namepatch3).Activate
[A65000].End(xlUp).Offset(0, 0).Select
Excel.Application.DisplayAlerts = False
' Définit la liste des filtres de fichiers
Filt = "Fichiers texte (*.txt),*.txt," & _
"Fichiers Lotus (*.prn),*.prn," & _
"Fichiers séparés par des virgules (*.csv),*.csv," & _
"Fichiers ASCII (*.asc),*.asc," & _
"Tous les fichiers (*.*),*.*"
' Affiche *.* par défaut
IndexFiltre = 5
' Définit la légende de la boîte de dialogue
Titre = "Sélectionner les fichiers à traiter"
' Obtenir le nom de fichier
NomFichier = Application.GetOpenFilename _
(fileFilter:=Filt, _
FilterIndex:=IndexFiltre, _
Title:=Titre, _
MultiSelect:=True)
' Quitter si la boîte de dialogue est annulée
If Not IsArray(NomFichier) Then
MsgBox "Aucun fichier n'a été sélectionné!"
GoTo TheEnd
End If
' Affiche le chemin complet et le nom des fichiers
Config = vbYesNo + vbInformation + vbDefaultButton2
For i = LBound(NomFichier) To UBound(NomFichier)
Msg = Msg & NomFichier(i)
Next i
Reponse = MsgBox("Ci-dessous vos fichiers selectionnés :" & vbCrLf & Msg & vbCrLf, Config, _
"MAJ resum")
If Reponse = vbNo Then GoTo TheEnd
For j = LBound(NomFichier) To UBound(NomFichier)
Msg1 = NomFichier(j)
Application.ScreenUpdating = False
Workbooks.Open Filename:=Msg1
Application.Calculation = xlCalculationManual
'Declare le classeur actif
Set wkb = ActiveWorkbook
'Affiche la barre de statut en bas à gauche de l'écran (si elle ne l'est pas déjà)
Application.StatusBar = "MAJ resum - Traitement fichier " & ActiveWorkbook.Name & " - merci de patienter SVP ..."
'------------------------------------------------------------------------------------------------------
'Ne selectionne que le nom du fichier à l'intérieur du chemin
fichier1 = Right(Msg1, Len(Msg1) - InStrRev(Msg1, "\", -1, 1))
fichier = Left(fichier1, InStr(fichier1, ".xls") - 1)
'traitement import
Windows(Namepatch3).Activate
[A65000].End(xlUp).Offset(1, 0).Select
ActiveCell.Value = fichier
ActiveCell.Offset(0, 0).Select
Windows(fichier1).Activate
Range("A2:S65000").Copy 'Donnees à copier : de la cellule A2 à S65000 car plage variable
Windows(Namepatch3).Activate
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
'------------------------------------------------------------------------------------------------------
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.StatusBar = False
'Libération de la ressource
Set wkb = Nothing
Windows(fichier1).Activate
ActiveWorkbook.Close
Next j
[A65000].End(xlUp).Offset(0, 0).Select
TheEnd:
End Sub
- Messages
- 1'794
- Excel
- 2010
- Inscrit
- 25/08/2014
- Emploi
- Consultant VB6 / SQL / VBA / Excel / Access
Bonjour et bienvenu !
Je pense lire assez bien le VBA, mais honnêtement, debugger 200 lignes en mode texte de visu semble un peu compliqué
Avant de coller les données, effectivement, il faudra récupérer la dernière ligne écrite, et coller à la suite.
A priori ici :
Windows(Namepatch3).Activate
'Récupère la dernière ligne
DerniereLigne = Sheets("feuil1").Range("A65000").End(x1Up).Row
'Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("A" & DerniereLigne).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Pour essayer de répondre à la question, merci de fournir le fichier principal, et un fichier à importer.
Cordialement
Bouben
Merci de ta réponse si rapide !
Finalement, j'ai posté ce message un peu trop rapidement.. Je viens de trouver la solution à mon problème !!
Il suffisait que je rajoute deux lignes :
Range("A65000").End(xlUp).Offset(1).Select 'recherche la première cellule vide
ActiveSheet.Paste 'copie les données
Et oui, désolée pour les lignes de code en txt... La prochaine fois je joindrai mon fichier.
Merci encore!
Bonjour,
essaye d'insérer la ligne surlignée
Windows(Namepatch3).Activate
Range("A" & Cells(Rows.Count, 1).End(xlUp).Row + 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Et pitié comme dit plus haut, utilise les balises [code ] [/code ], sinon c'est dur de trouver la motivation d'aider !
- Messages
- 1'794
- Excel
- 2010
- Inscrit
- 25/08/2014
- Emploi
- Consultant VB6 / SQL / VBA / Excel / Access
Bonjour Elhevan,
D'après le dernier message, le problème est résolu.
"Finalement, j'ai posté ce message un peu trop rapidement.. Je viens de trouver la solution à mon problème !! "
Cordialement
Bouben
Merci Elhevan! Ta solution fonctionne très bien aussi.
Désolée, c'était mon premier post ici, je n'ai absolument pas pensé aux balises ni rien.. La prochaine fois je le ferai!
Merci pour votre aide en tout cas
Je n'hésiterai pas à revenir vers vous si j'ai d'autres problèmes !
bouben a écrit :Bonjour Elhevan,
D'après le dernier message, le problème est résolu.
"Finalement, j'ai posté ce message un peu trop rapidement.. Je viens de trouver la solution à mon problème !! "
Cordialement
Bouben
Ouip, mais j'avais déjà écrit alors tant qu'à faire