VBA Boucle copier/coller dans boucle d extraction
Bonjour à tous
je souhaite avoir votre expertise pour ameliorer ma macro, apres plusieurs essais et recherches internet je ne trouve pas de solution qui fonctionne c est pourquoi je me tourne vers vous.
La macro qui suit a pour but : ouvrir l explorateur de fichier, permettre à l´utilisateur de selectionner 1 ou plusieurs fichiers, d en extraire des données et de les copier dans le fichier de la macro.
Le code suivant fonctionne pour 1 fichier :
Sub Macro1()
End Sub
Actuellement le fichier copie colle tout sur la meme colonne je voudrais donc ajouter une conditions qui dit : si le colonne i est vide alors copier à cette endroit sinon se decaler à la prochaine vide et copier ici, je voudrais que la macro fonctionne que je selectionne 10 fichiers d un coup ou 1 par 1. par exemple si j en ai selectionner 3 fichier, mes colonnes de 1 à 6 sont pleines et si j´ajoute une nouveau fichier alors les colonnes 7 et 8 se remplissent.
J´espere que mon explication est compréhensible
Ps : je suis débutant en VBA il est possible que meme si ce code fonctionne il y ait des abérrations
Ps2 : je joint ma macro et 2 fichiers avec des données à extraire
Pouvez vous s´il vous plait m´aider
Merci par avance
Jules
bonjour,
proposition de correction
Sub Macro1()
Application.EnableEvents = False
Dim wbsrc As Excel.Workbook ' déclarer le fichier source
Dim wbtrg As Excel.Workbook ' déclarer le fichier detinataire
Dim ws As Excel.Worksheet ' declarer les feuil
Dim intChoice As Integer 'Déclarer les variables de base
Dim fic As Integer
Dim i As Integer
Dim cellule As Range
Dim maref As String
Dim col As Integer
Dim lig As Integer
Dim x As Integer
Dim StrFile As String
Application.ScreenUpdating = False
Application.Cursor = xlWait
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
intChoice = .Show
If intChoice <> 0 Then
Set wbtrg = ThisWorkbook ' dire que c'est sur ce fichier que je travail
Set ws = wbtrg.Worksheets("Sheet1") ' coller le resultat dans la feuil source du fichier destinataire
i = ws.Cells(9, Columns.Count).End(xlToLeft).Column + 1 'Has to be the number of the column at the beginning of the table where you want to extract
For fic = 1 To .SelectedItems.Count
Workbooks.Open .SelectedItems(fic)
Set wbsrc = ActiveWorkbook
Set wk = wbsrc.Worksheets("all Dir static measurements")
maref = "S1_Z-Dir ±4KN"
Set cellule = wk.Cells.Find(maref, LookIn:=xlValues, SearchOrder:=xlByRows, MatchCase:=False)
If cellule Is Nothing Then
MsgBox "Ref not found !"
Exit Sub
End If
col = cellule.Column
lig = cellule.Row
x = lig + 5 'le nombre correspond au nbr de ligne entre la cellule maref et le premiere ligne de donnée
wk.Range("B" & x & ":B" & Range("B" & x).End(xlDown).Row).Copy Destination:=ws.Cells(9, i) 'copy and paste the data from the first line to the last not empty
wk.Range("C" & x & ":C" & Range("C" & x).End(xlDown).Row).Copy Destination:=ws.Cells(9, i + 1)
i = i + 2
wbsrc.Close savechanges:=False ' fermer le fichier source
Next fic
Set ws = Nothing
Set wbsrc = Nothing
Set wbtrg = Nothing
Else
MsgBox "La procédure est annulée car aucun fichier n’a été entré."
End If
End With
Application.ScreenUpdating = True
Application.Cursor = xlDefault
Application.EnableEvents = True
MsgBox "Import terminé"
End Subça fonctionne parfaitement
Merci beaucoup
Bonne journée à vous
Jules
Juste une question, je suis pas sur de comprendre comment vous donnez un colonnes de "depart" pour la ou vous collez, si par exemple je veux que ma première colonne de données collée soit la 10 eme comment je fais ? parceque en changeant
i = ws.Cells(9, Columns.Count).End(xlToLeft).Column + 8
je me retrouve bien avec la premiere décalée mais apres il y a un interval de 8 entre chaque colonne
Parceque apres je dois copier cette macro pour qu elle puisse se reproduire sur 20 type de test differents que je veux tous extraire dans un meme fichier mais dans des tableau differents (voir excel joint pour se representer la chose)
Merci a vous pour la rapidité de votre réponse précedente
re-bonjour,
j'avais laissé une ligne parasite dans le code que j'ai proposée. c'est entretemps corrigé (voir plus haut)
pour commencer à la colonne 10, plutot qu'à la première colonne à droite de la dernière colonne utilisée, il faut remplacer
i = ws.Cells(9, Columns.Count).End(xlToLeft).Column + 1 'Has to be the number of the column at the beginning of the table where you want to extractpar
i = 10 'Has to be the number of the column at the beginning of the table where you want to extractMerci encore pour votre réponse rapide
Mais du coup si je remplace i = ws.Cells(9, Columns.Count).End(xlToLeft).Column + 1 par i=10 tout le principe d ajouter une les colonnes les une à la suite des autres ne fonctionne plus, quand j en extrait une puis que j´en extrait une autre elle prend juste sa place non ? y aurait il un moyen d´avoir les deux ?
Parceque votre version est vraiment parfaite et correspond excatement à ce que je voulais, seulement mes tableaux dans lesquels je souhaite extraire ne commence jamais à la colonne 2
Du coup j aimerai pouvoir choisir la première colonne et garder le principe de commencer à droite de la dernière utilisée
Merci pour votre aide
bonjour,
j'ai dû mal à comprendre ceci
(...) seulement mes tableaux dans lesquels je souhaite extraire ne commence jamais à la colonne 2 (...)
la macro ouvre tous les fichiers sélectionnés et copie toujours les colonnes 2 et 3 du fichier source. Je suppose que tu parles de la colonne de destination qui ne peut jamais être la 2ème.
voici une correction, selon cette compréhension.
Sub Macro1()
Application.EnableEvents = False
Dim wbsrc As Excel.Workbook ' déclarer le fichier source
Dim wbtrg As Excel.Workbook ' déclarer le fichier detinataire
Dim ws As Excel.Worksheet ' declarer les feuil
Dim intChoice As Integer 'Déclarer les variables de base
Dim fic As Integer
Dim i As Integer, dc As Long
Dim cellule As Range
Dim maref As String
Dim col As Integer
Dim lig As Integer
Dim x As Integer
Dim StrFile As String
Application.ScreenUpdating = False
Application.Cursor = xlWait
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
intChoice = .Show
If intChoice <> 0 Then
Set wbtrg = ThisWorkbook ' dire que c'est sur ce fichier que je travail
Set ws = wbtrg.Worksheets("Sheet1") ' coller le resultat dans la feuil source du fichier destinataire
i = 10 'première colonne
dc = ws.Cells(9, Columns.Count).End(xlToLeft).Column + 1 'Has to be the number of the column at the beginning of the table where you want to extract
If dc < i Then dc = i
For fic = 1 To .SelectedItems.Count
Workbooks.Open .SelectedItems(fic)
Set wbsrc = ActiveWorkbook
Set wk = wbsrc.Worksheets("all Dir static measurements")
maref = "S1_Z-Dir ±4KN"
Set cellule = wk.Cells.Find(maref, LookIn:=xlValues, SearchOrder:=xlByRows, MatchCase:=False)
If cellule Is Nothing Then
MsgBox "Ref not found !"
Exit Sub
End If
col = cellule.Column
lig = cellule.Row
x = lig + 5 'le nombre correspond au nbr de ligne entre la cellule maref et le premiere ligne de donnée
wk.Range("B" & x & ":B" & Range("B" & x).End(xlDown).Row).Copy Destination:=ws.Cells(9, i) 'copy and paste the data from the first line to the last not empty
wk.Range("C" & x & ":C" & Range("C" & x).End(xlDown).Row).Copy Destination:=ws.Cells(9, i + 1)
i = i + 2
wbsrc.Close savechanges:=False ' fermer le fichier source
Next fic
Set ws = Nothing
Set wbsrc = Nothing
Set wbtrg = Nothing
Else
MsgBox "La procédure est annulée car aucun fichier n’a été entré."
End If
End With
Application.ScreenUpdating = True
Application.Cursor = xlDefault
Application.EnableEvents = True
MsgBox "Import terminé"
End Suboui c´est bien ça je me suis mal exprimé.
Par contre la solution n´est pas exactement ça, désolé je suis chiant j´imagine. Merci beaucoup pour votre aide
Si c est pas trop demandé j´aimerai juste savoir comment faire, parceque avec votre derniere solution si je selectionne plusieurs fichiers en meme temps et avec i=10 alors ça me les colles bien tous à partir de la colonne 10 donc parfait, mais si je les selectionne 1 par 1 ça remplace juste et je peux pas les avoirs à la suite. Je sais pas si c´est possible d´avoir les deux solutions en meme temps.
merci pour votre temps, vous m´avez déja beaucoup aidé
re-bonjour,
je crois que je ne suis pas bien réveillé, désolé. voici une correction
Sub Macro1()
Application.EnableEvents = False
Dim wbsrc As Excel.Workbook ' déclarer le fichier source
Dim wbtrg As Excel.Workbook ' déclarer le fichier detinataire
Dim ws As Excel.Worksheet ' declarer les feuil
Dim intChoice As Integer 'Déclarer les variables de base
Dim fic As Integer
Dim i As Integer, dc As Long
Dim cellule As Range
Dim maref As String
Dim col As Integer
Dim lig As Integer
Dim x As Integer
Dim StrFile As String
Application.ScreenUpdating = False
Application.Cursor = xlWait
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
intChoice = .Show
If intChoice <> 0 Then
Set wbtrg = ThisWorkbook ' dire que c'est sur ce fichier que je travail
Set ws = wbtrg.Worksheets("Sheet1") ' coller le resultat dans la feuil source du fichier destinataire
i = 10 'première colonne
dc = ws.Cells(9, Columns.Count).End(xlToLeft).Column + 1 'Has to be the number of the column at the beginning of the table where you want to extract
If dc > i Then i = dc
For fic = 1 To .SelectedItems.Count
Workbooks.Open .SelectedItems(fic)
Set wbsrc = ActiveWorkbook
Set wk = wbsrc.Worksheets("all Dir static measurements")
maref = "S1_Z-Dir ±4KN"
Set cellule = wk.Cells.Find(maref, LookIn:=xlValues, SearchOrder:=xlByRows, MatchCase:=False)
If cellule Is Nothing Then
MsgBox "Ref not found !"
Exit Sub
End If
col = cellule.Column
lig = cellule.Row
x = lig + 5 'le nombre correspond au nbr de ligne entre la cellule maref et le premiere ligne de donnée
wk.Range("B" & x & ":B" & Range("B" & x).End(xlDown).Row).Copy Destination:=ws.Cells(9, i) 'copy and paste the data from the first line to the last not empty
wk.Range("C" & x & ":C" & Range("C" & x).End(xlDown).Row).Copy Destination:=ws.Cells(9, i + 1)
i = i + 2
wbsrc.Close savechanges:=False ' fermer le fichier source
Next fic
Set ws = Nothing
Set wbsrc = Nothing
Set wbtrg = Nothing
Else
MsgBox "La procédure est annulée car aucun fichier n’a été entré."
End If
End With
Application.ScreenUpdating = True
Application.Cursor = xlDefault
Application.EnableEvents = True
MsgBox "Import terminé"
End SubC est parfait
tout fonctionne niquel, merci pour votre temps et votre réactivité
Bonne fin de journée
Jules
Bonjour, je me permets de réouvrir le sujet.
La macro fonctionne tres bien seulement je rencontre un nouveau problème que je peine à résoudre
Pour bien comprendre voir l excel joint, à la feuille "X Data". pour le premier Tableau tout fonctionne bien mais apres quand je veux ajouter une nouvelle série de donnée aprés avoir fais les macros de chaque tableau, elle se met automatiquement dans le dernier tableau (j ai mis de la meme couleur l endroit ou c´était supposé ce mettre et l endroit ou elles se mettent)
J´ai compris d´ou vient le problème, puisque c est la ligne : dc = ws.Cells(11, Columns.Count).End(xlToLeft).Column + 1 qui fait ça, mais je n ai aucune idée de comment résoudre ce problème et internet ne m a pas vraiment aidé pour le moment
Pensez vous qu il est possible de garder le principe de se mettre à droite de la dernière colonne non vide mais en restant sur le meme tableau et que je puisse repeter le motif plusieurs fois sur different tableau d´une meme feuille
Merci par avance
Jules
bonsoir,
essaie en modifiant cette instruction
dc = ws.Cells(11, Columns.Count).End(xlToLeft).Column + 1ainsi
dc = ws.Cells(11, i + 20).End(xlToLeft).Column + 1la macro cherchera le numéro de la première colonne non vide à gauche de la colonne i+20 et lui ajoutera 1
Bonjour,
Cette fois ci c´est bon la macro fonctionne parfaitement et elle est terminée
Merci beaucoup à vous
Bonne journée
Jules