Récupération données fichier source VBA
Bonjour le forum,
Je me permets de solliciter votre aide car je bloque sur un sujet. Je vais essayer d'être le plus clair possible.
J'ai un dossier, dans lequel tous les jours un nouveau fichier excel au format XXaaaammdd vient s'ajouter en plus de ceux existants (confère dossier joint XX20220412). Je souhaite copier certaines lignes de ce fichier selon une condition. Dans mon exemple je souhaite copier les lignes dont le "Portefeuille" est égal à "A" et les coller les unes à la suite des autres dans mon fichier "dernierfichier" en partant de A2 par exemple. Le code VBA dans ce fichier permet de retrouver le dernier fichier du dossier en fonction de sa date de création et de l'ouvrir. C'est après que je bloque, je suis incapable de trouver un code qui puisse me permettre de faire les étapes citées précédemment. Je souhaite répéter cette opération tous les jours et ainsi écraser les données de la veille dans mon fichier "dernierfichier".
Merci de votre aide.
Bonsoir Gupette, bonsoir le forum,
Essaie comme ça :
Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim MemFic As String 'déclare la variable MemFic
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim F As String 'déclare la variable F (Fichier)
Dim FMax As String 'déclare la variable FMax (Fichier Max)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Byte 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets(1) 'définit l'onglet destination CD
CA = CD.Path & "\" 'définit le chemin d'accès (à adapter à ton cas sans oublier "\" à la fin)
F = Dir(CA & "xx????????.xlsx") 'définit le premier classeur F commençant par xx suivi de 8 caractères variables et ayant CA comme chemin d'accès
Do While F <> "" 'boucle tant qu'il existe un fichier F
'si le texte à partir du 3ème caractère de F est supérieur à MemFic alors Memfic devient ce texte et le fichier FMax devient F
If Mid(F, 3) > MemFic Then MemFic = Mid(F, 3): FMax = F
F = Dir 'définit le prochain fichier F ayant les mêmes caractéristiques et ayant CA comme chemin D'accès
Loop 'boucle
Set CS = Workbooks.Open(CA & FMax) 'définit le classeur source CS en l'ouvrant
Set OS = CS.Worksheets(1) 'définit l'onglet source OS
TV = OS.Range("A1").CurrentRegion 'définit la tableau des valeurs TV
For I = 2 To UBound(TV, 1) 'boucle 1 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
If TV(I, 4) = "A" Then 'condition : si la donnée ligne I colonne 4 de TV est égale à A
K = K + 1 'incrémente K
ReDim Preserve TL(1 To 4, 1 To K) 'redimensionne le tableau des lignes TL (autant de ligne que TV a de colonnes, K colonnes)
For J = 1 To 4 'boucle 2 : sur les 4 colonnes J du tableau des valeurs TV
TL(J, K) = TV(I, J) 'récupère dans la ligne J de TL la donnée en colonne J de TV (=> Transposition)
Next J 'prochaine colonne de la boucle 2
End If 'fin de la condition
Next I 'prochaine ligne de la boucle 1
CS.Close False 'ferme le classeur source sans enregistrer
If K > 0 Then 'condition : si K est supérieure à zéro
OD.Range("A1").CurrentRegion.Offset(1, 0).ClearContents 'efface les anciennes valeurs de l'onglet OD
'renvoie dans A2 redimensionnée de l'onglet OD le tableau TL transposé
OD.Range("A2").Resize(K, 4).Value = Application.Transpose(TL)
End If
CD.Save 'enregistre le classeur destination
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End SubBonjour,
Une proposition Power Query.
Pour Excel 2010, il est nécessaire d'installer le complement gratuit Microsoft.
Le fichier gupette.xlsx consolide tous les fichiers du dossier "Fichiers".
Les données sont actualisées à l'ouverture de ce fichier.
Pour tester, mettre le fichier xx20220413.xlsx dans le répertoire Fichier.
Cdlt.
Bonjour Thauthème,
Merci de votre retour très complet. J'ai lancé le code depuis mon fichier "dernierfichiercopie" etj'ai un bug sur le code que je ne comprends pas.
Set CS = Workbooks.Open(CA & FMax) 'définit le classeur source CS en l'ouvrant ==> il me dit qu'il est incapable de trouver le fichier...
Sommes-nous d'accord que "xx20220412" représente mon fichier source et que "dernierfichiercopie" représente mon fichier destination ?
Pouvez-vous m'expliquer ces deux lignes également ?
- CA = CD.Path & "\" 'définit le chemin d'accès (à adapter à ton cas sans oublier "\" à la fin) ==> pour moi le chemin d'accès doit correspondre à mon dossier ou sont répertoriés tous mes fichiers excel sous la forme XXaaaammdd, dans lequel est rajouté tous les jours un nouveau fichier automatiquement, par exemple aujourd'hui j'aurais le fichier xx20220413
Merci encore de votre réponse.
Bonjour le fil, bonjour le forum,
Oui oui je suis bien d'accord avec le fichier source et le fichier destination.
Je pense que l'erreur est due au chemin d'accès CA. Pour simplifier, je l'ai défini comme étant le chemin d'accès du classeur destination d'où le code :
CA = CD.Path & "\"S'il est différent que celui du fichier source il te faut : soit le rentrer en dur (si c'est toujours le même) :
CA = C:\blabla\blablabla\blabla\soit coder pour aller le cherche en début de macro :
Option Explicit
Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim RD As Object 'déclare la variable RD (recherche du dossier)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim MemFic As String 'déclare la variable MemFic
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim F As String 'déclare la variable F (Fichier)
Dim FMax As String 'déclare la variable FMax (Fichier Max)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Byte 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets(1) 'définit l'onglet destination CD
Set RD = Application.FileDialog(msoFileDialogFolderPicker) 'définit la recherche du dossier RD
RD.AllowMultiSelect = False 'n'autorise qu'une seule sélection
RD.Show 'affiche la boîte de dialogue
If RD.SelectedItems.Count > 0 Then 'si un dossier a été sélectionné
CA = RD.SelectedItems(1) & "\" 'définit le chemin d'accès CA
Else 'sinon
MsgBox "Vous devez sélectionner le dossier contenant les fichiers à traiter !"
Exit Sub 'sort de la procédure
End If 'fin de la condition
F = Dir(CA & "xx????????.xlsx") 'définit le premier classeur F commençant par xx suivi de 8 caractères variables et ayant CA comme chemin d'accès
Do While F <> "" 'boucle tant qu'il existe un fichier F
'si le texte à partir du 3ème caractère de F est supérieur à MemFic alors Memfic devient ce texte et le fichier FMax devient F
Debug.Print Mid(F, 3, 8)
If Mid(F, 3, 8) > MemFic Then MemFic = Mid(F, 3, 8): FMax = F
F = Dir 'définit le prochain fichier F ayant les mêmes caractéristiques et ayant CA comme chemin D'accès
Loop 'boucle
Set CS = Workbooks.Open(CA & FMax) 'définit le classeur source CS en l'ouvrant
Set OS = CS.Worksheets(1) 'définit l'onglet source OS
TV = OS.Range("A1").CurrentRegion 'définit la tableau des valeurs TV
For I = 2 To UBound(TV, 1) 'boucle 1 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
If TV(I, 4) = "A" Then 'condition : si la donnée ligne I colonne 4 de TV est égale à A
K = K + 1 'incrémente K
ReDim Preserve TL(1 To 4, 1 To K) 'redimensionne le tableau des lignes TL (autant de ligne que TV a de colonnes, K colonnes)
For J = 1 To UBound(TV, 2) 'boucle 2 : sur toutes les colonnes J du tableau des valeurs TV
TL(J, K) = TV(I, J) 'récupère dans la ligne J de TL la donnée en colonne I de TV (=> Transposition)
Next J 'prochaine colonne de la boucle 2
End If 'fin de la condition
Next I 'prochaine ligne de la boucle 1
CS.Close False 'ferme le classeur source sans enregistrer
If K > 0 Then 'condition : si K est supérieure à zéro
OD.Range("A1").CurrentRegion.Offset(1, 0).ClearContents 'efface les anciennes valeurs de l'onglet OD
'renvoie A2 redimensionnée de l'onglet OD le tableau TL transposé
OD.Range("A2").Resize(K, UBound(TV, 2)).Value = Application.Transpose(TL)
End If
CD.Save 'enregistre le classeur destination
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
End SubBonjour Thauthème et en particulier à Jean-Eric que le demandeur malotru ignore grossièrement...
Sans doute qu'il PETTE plus haut que son GU
Bonsoir Thauthème, bonsoir le forum,
Merci de votre retour. Désolé de vous embêter encore une fois, je n'arrive pas à comprendre dans votre code, comment vous arrivez à rechercher le dernier fichier ajouté dans mon dossier en fonction de la date de modification avec cette ligne : "Set CS = Workbooks.Open(CA & FMax) 'définit le classeur source CS en l'ouvrant" ? Même en rentrant en dur le chemin de mon dossier dans lequel se trouve mes fichiers sources mis à jour quotidiennement, j'ai toujours un problème de chemin d'accès. Egalement, je ne comprends pas très bien cette ligne de code "F = Dir(CA & "xx????????.xlsx")", car c'est précisément un code VBA qui est supposé me trouver le dernier fichier modifié dans mon dossier ?
Encore une fois merci de votre temps passé sur ces explications.
Bonjour le fil, bonjour le forum,
La remarque de Chris a autant d'effet sur toi qu'une promesse électorale sur moi. C'est regrettable et pas très sympathique et ça ne m'engage pas à continuer de t'aider.
Mon code est suffisamment commenté et il y a l'aide VBA qui te fournira des explications. Ce que je peux te dire c'est qu'il fonctionne chez moi avec le fichier destination que tu as fourni et le fichier source que j'ai copié six fois en le renomment xx20220412.xlsx à xx20220417.xlxs.
C'est cette partie qui détermine le dernier fichier :
Do While F <> "" 'boucle tant qu'il existe un fichier F
'si le texte à partir du 3ème caractère de F est supérieur à MemFic alors Memfic devient ce texte et le fichier FMax devient F
If Mid(F, 3, 8) > MemFic Then MemFic = Mid(F, 3, 8): FMax = F
F = Dir 'définit le prochain fichier F ayant les mêmes caractéristiques et ayant CA comme chemin D'accès
Loop 'boucleBonjour Thauthème,
Merci de votre retour. Je vais essayer de regarder cela avec plus d'attention et je me permettrai de revenir vers vous si je bloque une nouvelle fois.
Pour votre information, j'ai crée un topic similaire dans lequel Jean-Eric m'a fournit cette solution, je l'ai remercié chaleureusement et lui ai signifié que je voulais passer par du VBA et non Power Query pour des raisons pratiques. Peut être que que 78chris aurait moins CHRISSER des dents si il avait eu toute l'information entre ses mains...
Re,
Peut-être, mais cette totale indifférence est assez surprenante.
Je ne l'avais pas expliqué mais avec le code il te suffit de sélectionner le dossier dans lequel se trouvent les fichier et de valider avec le bouton Ok pour déterminer le chemin d'accès. J'avais oublié d'effacer les anciennes valeurs... C'est réparé dans celui-ci :
Option Explicit
Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim RD As Object 'déclare la variable RD (recherche du dossier)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim MemFic As String 'déclare la variable MemFic
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim F As String 'déclare la variable F (Fichier)
Dim FMax As String 'déclare la variable FMax (Fichier Max)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Byte 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets(1) 'définit l'onglet destination CD
OD.Range("A1").CurrentRegion.Offset(1, 0).ClearContents 'efface les anciennes valeurs
Set RD = Application.FileDialog(msoFileDialogFolderPicker) 'définit la recherche du dossier RD
RD.AllowMultiSelect = False 'n'autorise qu'une seule sélection
RD.Show 'affiche la boîte de dialogue
If RD.SelectedItems.Count > 0 Then 'si un dossier a été sélectionné
CA = RD.SelectedItems(1) & "\" 'définit le chemin d'accès CA
Else 'sinon
MsgBox "Vous devez sélection le dossier contenant les fichiers à traiter !"
Exit Sub 'sort de la procédure
End If 'fin de la condition
F = Dir(CA & "xx????????.xlsx") 'définit le premier classeur F commençant par xx suivi de 8 caractères variables et ayant CA comme chemin d'accès
Do While F <> "" 'boucle tant qu'il existe un fichier F
'si le texte à partir du 3ème caractère de F est supérieur à MemFic alors Memfic devient ce texte et le fichier FMax devient F
If Mid(F, 3, 8) > MemFic Then MemFic = Mid(F, 3, 8): FMax = F
F = Dir 'définit le prochain fichier F ayant les mêmes caractéristiques et ayant CA comme chemin D'accès
Loop 'boucle
Set CS = Workbooks.Open(CA & FMax) 'définit le classeur source CS en l'ouvrant
Set OS = CS.Worksheets(1) 'définit l'onglet source OS
TV = OS.Range("A1").CurrentRegion 'définit la tableau des valeurs TV
For I = 2 To UBound(TV, 1) 'boucle 1 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
If TV(I, 4) = "A" Then 'condition : si la donnée ligne I colonne 4 de TV est égale à A
K = K + 1 'incrémente K
ReDim Preserve TL(1 To 4, 1 To K) 'redimensionne le tableau des lignes TL (autant de ligne que TV a de colonnes, K colonnes)
For J = 1 To UBound(TV, 2) 'boucle 2 : sur toutes les colonnes J du tableau des valeurs TV
TL(J, K) = TV(I, J) 'récupère dans la ligne J de TL la donnée en colonne I de TV (=> Transposition)
Next J 'prochaine colonne de la boucle 2
End If 'fin de la condition
Next I 'prochaine ligne de la boucle 1
CS.Close False 'ferme le classeur source sans enregistrer
If K > 0 Then 'condition : si K est supérieure à zéro
OD.Range("A1").CurrentRegion.Offset(1, 0).ClearContents 'efface les anciennes valeurs de l'onglet OD
'renvoie A2 redimensionnée de l'onglet OD le tableau TL transposé
OD.Range("A2").Resize(K, UBound(TV, 2)).Value = Application.Transpose(TL)
End If
CD.Save 'enregistre le classeur destination
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
End SubMerci de votre retour. Je n'ai pas eu encore le temps de m'y remettre, je vous tiens informé dès que possible.
Je suis toujours pour maintenir l'entente la plus cordiale sur ce forum qui m'a rendu bien des services.
Bonjour Thauthème, bonjour le forum,
Je vous prie de m'excuser pour ce retour tardif, j'étais souffrant. Je me suis remis dans le code. Effectivement votre code me demande bien de sélectionner le dossier dans lequel faire ma recherche de fichiers le plus récent. Cependant, lorsque je double clique sur le dossier en question pour m'assurer quel celui-ci contient bien les fichiers, le dossier est vide, la macro me dit qu'elle ne reconnait pas le chemin d'accès et bug à la ligne suivante ;
Set CS = Workbooks.Open(CA & FMax) 'définit le classeur source CS en l'ouvrant
Lorsque je sors du code et que je double clique sur mon dossier en question, je vous confirme que celui-ci est n'est pas vide. Aurais-je oublier de cliquer sur une référence qui ferait que la liaison entre VBA et mon dossier ne peut pas se faire ? Merci à vous
Bonsoir Gupette, bonsoir le forum,
En effet ! Le code n'est pas prévu pour vérifier mais pour agir. Il te faut d'abord vérifier dans Explorateur où se trouve les fichier... Puis après tu ne fais que sélectionner le dossier en question... Ou alors il faut revoir le code et commencer par recherche le dossier...
Bonjour Thauthème & le forum,
Après plusieurs tests, un grand merci Thauthème pour votre aide, cela fonctionne bien. J'ai retenu la première solution, à savoir inscrire le chemin d'accès en dur. J'aurais une dernière chose à vous demander. Est-il possible de ne pas faire une transcription complète de la ligne mais uniquement de certaines colonnes de mon fichier source vers mon fichier destination ? Je voudrais par exemple dans mon fichier source extraire uniquement les données contenues dans la colonne A et la colonne C par exemple, toujours sous contrainte de mon critère initial. Merci
Bonjour le fil, bonjour le forum,
Pour éviter toutes confusion et de perdre du temps, peux-tu nous envoyer le code que tu utilises actuellement ou mieux le fichier.
Sinon, par rapport au code précédent le voici adapté :
Option Explicit
Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim RD As Object 'déclare la variable RD (recherche du dossier)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim MemFic As String 'déclare la variable MemFic
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim F As String 'déclare la variable F (Fichier)
Dim FMax As String 'déclare la variable FMax (Fichier Max)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Byte 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets(1) 'définit l'onglet destination CD
OD.Range("A1").CurrentRegion.Offset(1, 0).ClearContents 'efface les anciennes valeurs
Set RD = Application.FileDialog(msoFileDialogFolderPicker) 'définit la recherche du dossier RD
RD.AllowMultiSelect = False 'n'autorise qu'une seule sélection
RD.Show 'affiche la boîte de dialogue
If RD.SelectedItems.Count > 0 Then 'si un dossier a été sélectionné
CA = RD.SelectedItems(1) & "\" 'définit le chemin d'accès CA
Else 'sinon
MsgBox "Vous devez sélection le dossier contenant les fichiers à traiter !"
Exit Sub 'sort de la procédure
End If 'fin de la condition
F = Dir(CA & "xx????????.xlsx") 'définit le premier classeur F commençant par xx suivi de 8 caractères variables et ayant CA comme chemin d'accès
Do While F <> "" 'boucle tant qu'il existe un fichier F
'si le texte à partir du 3ème caractère de F est supérieur à MemFic alors Memfic devient ce texte et le fichier FMax devient F
If Mid(F, 3, 8) > MemFic Then MemFic = Mid(F, 3, 8): FMax = F
F = Dir 'définit le prochain fichier F ayant les mêmes caractéristiques et ayant CA comme chemin D'accès
Loop 'boucle
Set CS = Workbooks.Open(CA & FMax) 'définit le classeur source CS en l'ouvrant
Set OS = CS.Worksheets(1) 'définit l'onglet source OS
TV = OS.Range("A1").CurrentRegion 'définit la tableau des valeurs TV
For I = 2 To UBound(TV, 1) 'boucle 1 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
If TV(I, 4) = "A" Then 'condition : si la donnée ligne I colonne 4 de TV est égale à A
K = K + 1 'incrémente K
'********************* <----- Changement
ReDim Preserve TL(1 To 2, 1 To K) 'redimensionne le tableau des lignes TL (2 lignes, K colonnes)
TL(1, K) = TV(I, 1) 'récupère dans la ligne 1 de TL la donnée en colonne 1 de TV (=> Transposition)
TL(2, K) = TV(I, 3) 'récupère dans la ligne 2 de TL la donnée en colonne 3 de TV (=> Transposition)
'********************* <----- Changement
Next J 'prochaine colonne de la boucle 2
End If 'fin de la condition
Next I 'prochaine ligne de la boucle 1
CS.Close False 'ferme le classeur source sans enregistrer
If K > 0 Then 'condition : si K est supérieure à zéro
OD.Range("A1").CurrentRegion.Offset(1, 0).ClearContents 'efface les anciennes valeurs de l'onglet OD
'renvoie A2 redimensionnée de l'onglet OD le tableau TL transposé
OD.Range("A2").Resize(K, UBound(TV, 2)).Value = Application.Transpose(TL)
End If
CD.Save 'enregistre le classeur destination
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
End SubBonjour Thauthème & le forum,
Merci pour ce retour rapide, j'y suis presque ! En fait mon tableau source initial comporte plus que 4 colonnes, 11 en réalité. Je pensais que si j'avais un exemple j'aurais pu me débrouiller par moi-même pour la suite. Le code était bon dès le début, c'est moi qui ai cafouillé car l'extension de mes fichiers sources est en xls et non en xslx...forcément la macro m'indiquait qu'elle ne trouvait pas le fichier ...Je ne passe pas par la sélection du dossier (2ème solution fournie par vous) j'ai donc enlever la variable RD. Voici le code que j'utilise et qui fonctionne très bien. Je me suis permis d'ajouter encore quelques colonnes dans mon fichier destination. Le problème, c'est que le code copie bien les données voulues dans les cinq premières colonnes dans mon fichier destination, mais également de la colonne 6 jusqu'à la dernière colonne (11ème) avec la valeur #N/A inscrite dans ces colonnes. Ci-dessous, le code, j'ai volontairement enlevé les chemins par souci de confidentialité ;
Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim MemFic As String 'déclare la variable MemFic
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim F As String 'déclare la variable F (Fichier)
Dim FMax As String 'déclare la variable FMax (Fichier Max)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Byte 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets(1) 'définit l'onglet destination CD
CA = "" 'définit le chemin d'accès (à adapter à ton cas sans oublier "\" à la fin)
F = Dir(CA & " " & "????????" & ".xls") 'définit le premier classeur F commençant par xx suivi de 8 caractères variables et ayant CA comme chemin d'accès
Do While F <> "" 'boucle tant qu'il existe un fichier F
'si le texte à partir du 3ème caractère de F est supérieur à MemFic alors Memfic devient ce texte et le fichier FMax devient F
If Mid(F, 3) > MemFic Then MemFic = Mid(F, 3): FMax = F
F = Dir 'définit le prochain fichier F ayant les mêmes caractéristiques et ayant CA comme chemin D'accès
Loop 'boucle
Set CS = Workbooks.Open(CA & FMax) 'définit le classeur source CS en l'ouvrant
Set OS = CS.Worksheets(1) 'définit l'onglet source OS
TV = OS.Range("A4").CurrentRegion 'définit la tableau des valeurs TV
For I = 2 To UBound(TV, 1) 'boucle 1 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
If TV(I, 11) = "A" Then 'condition : si la donnée ligne I colonne 11 de TV est égale à A
K = K + 1 'incrémente K
ReDim Preserve TL(1 To 5, 1 To K) 'redimensionne le tableau des lignes TL (2 lignes, K colonnes)
TL(1, K) = TV(I, 1) 'récupère dans la ligne 1 de TL la donnée en colonne 1 de TV (=> Transposition)
TL(2, K) = TV(I, 2) 'récupère dans la ligne 2 de TL la donnée en colonne 3 de TV (=> Transposition)
TL(3, K) = TV(I, 6) 'récupère dans la ligne 2 de TL la donnée en colonne 3 de TV (=> Transposition)
TL(4, K) = TV(I, 7) 'récupère dans la ligne 2 de TL la donnée en colonne 3 de TV (=> Transposition)
TL(5, K) = TV(I, 8) 'récupère dans la ligne 2 de TL la donnée en colonne 3 de TV (=> Transposition)
'********************* <----- Changement
'Next J 'prochaine colonne de la boucle 2
End If 'fin de la condition
Next I 'prochaine ligne de la boucle 1
' CS.Close False 'ferme le classeur source sans enregistrer
If K > 0 Then 'condition : si K est supérieure à zéro
OD.Range("A1").CurrentRegion.Offset(1, 0).ClearContents 'efface les anciennes valeurs de l'onglet OD
'renvoie dans A2 redimensionnée de l'onglet OD le tableau TL transposé
OD.Range("A2").Resize(K, 11).Value = Application.Transpose(TL)
End If
CD.Save 'enregistre le classeur destination
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub
Je précise pour les autres, que le nom de mon fichier source est sous la forme xxx_AAAAMMJJ_zz.xls
Re,
Remplace cette ligne :
OD.Range("A2").Resize(K, 11).Value = Application.Transpose(TL)par :
OD.Range("A2").Resize(K, 5).Value = Application.Transpose(TL)Bonjour Tahuthème et le forum,
Effectivement en relisant le code c'était là que ça coinçait...merci encore pour votre réponse rapide et efficace. Une dernière chose si cela est possible, je m'explique :
- une première condition a été créée pour ne copier que les valeurs dont la colonne 11 est égal à "A"
For I = 2 To UBound(TV, 1) 'boucle 1 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
If TV(I, 11) = "A" Then 'condition : si la donnée ligne I colonne 11 de TV est égale à A
Je souhaiterai une fois cette première condition remplie, rajouter une autre condition qui ferait que si une valeur dans la colonne D de mon fichier source contienne "m", alors en colonne F de mon fichier destination coller un texte en dur type "go" et la valeur contenue dans la colonne G de mon fichier source. Autrement coller dans mon fichier destination un autre texte en dur type "no go" et la valeur contenue dans la colonne G de mon fichier source. Ci-dessous, une première capture d'écran de mon fichier source, ainsi qu'une seconde capture d'écran du résultat attendu dans mon fichier destination. Merci de votre aide encore une fois.
Bonjour Gupette, bonjour le forum,
La partie boucle modifiée :
For I = 2 To UBound(TV, 1) 'boucle 1 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
If TV(I, 11) = "A" Then 'condition : si la donnée ligne I colonne 11 de TV est égale à A
K = K + 1 'incrémente K
ReDim Preserve TL(1 To 6, 1 To K) 'redimensionne le tableau des lignes TL (2 lignes, K colonnes)
TL(1, K) = TV(I, 1) 'récupère dans la ligne 1 de TL la donnée en colonne 1 de TV (=> Transposition)
TL(2, K) = TV(I, 2) 'récupère dans la ligne 2 de TL la donnée en colonne 3 de TV (=> Transposition)
TL(3, K) = TV(I, 6) 'récupère dans la ligne 3 de TL la donnée en colonne 3 de TV (=> Transposition)
TL(4, K) = TV(I, 7) 'récupère dans la ligne 4 de TL la donnée en colonne 3 de TV (=> Transposition)
TL(5, K) = TV(I, 8) 'récupère dans la ligne 5 de TL la donnée en colonne 3 de TV (=> Transposition)
TL(6, K) = IIf(TV(I, 3) = "m", "go " & TV(I, 7), "no go " & TV(I, 7)) 'récupère dans la ligne 6 de TL la donnée en colonne 7 de TV (=> Transposition)
End If 'fin de la condition
Next I 'prochaine ligne de la boucle 1N'oublie pas à la fin :
OD.Range("A2").Resize(K, 6).Value = Application.Transpose(TL)