Manip sur cellules fichiers fermes

V

VBANOVICE

XLDnaute Junior
Bonjour a tous

Grace à ce site merveilleux, je pense avoir trouvé une macro pour recuperer des cellules dans des dossiers ferme, mais j'ai besoin de votre aide pour l'adapter.

j'aimerais que la cellule d5 du fichier ferme soit dans c14 du fichier requette
d6 du fichier ferme soit dans d14 du fichier requette
d7 du fichier ferme soit dans e14 du fichier requette
d8 du fichier ferme soit dans f14 du fichier requette
m6 du fichier ferme soit dans g14 du fichier requette
m7 du fichier ferme soit dans h14 du fichier requette
m9 du fichier ferme soit dans i14 du fichier requette
m10 du fichier ferme soit dans j14 du fichier requette

ensuite on passe au fichier ferme n+1 qui irra à la ligne 15 et ainsi de suite

si joint la macro de michelxld:

Option Explicit
Option Base 1

Sub importerDonneesClasseursFermes()
'michelxld le 31.05.2005
'necessite d'activer la reference Microsoft ActiveX Data Objects x.x Library
'necessite d 'activer la reference Microsoft ADO Ext 2.7 for DLL ans Security
Dim Cn As ADODB.Connection
Dim Rs As ADODB.Recordset
Dim Cat As ADOX.Catalog
Dim xConnect As String, Cible As String
Dim Fichier As String, Champ As String, Feuille As String
Dim Tableau()
Dim i As Byte, NumRec As Byte, j As Byte

Fichier = Dir(ThisWorkbook.Path & "\*.xls") 'adapter chemin


Do While Len(Fichier) > 0 'boucler sur les fichiers du repertoire

If Fichier <> ThisWorkbook.Name Then

xConnect = "DRIVER={Microsoft Excel Driver (*.xls)};" & _
"ReadOnly=1;DBQ=" & ThisWorkbook.Path & "\" & Fichier

j = j + 1
Set Cat = CreateObject("ADOX.Catalog")
Set Cn = CreateObject("ADODB.Connection")

Cn.Open xConnect
Set Cat.ActiveConnection = Cn

Feuille = Cat.Tables(0).Name 'nom de la 1ere feuille du classeur fermé
Champ = Cat.Tables(0).Columns(5).Name ' nom d'entete de la 6eme colonne du classeur fermé
Tableau = Array(11, 13, 17, 19, 21, 30, 109) 'les valeurs doivent etre dans l'ordre croissant
NumRec = 2 '2 car l'index du 1er champ =0 et la 1ere ligne dans le classeur fermé
'correspond à l'entete

Cible = "SELECT " & Champ & " FROM [" & Feuille & "];"

Set Rs = New ADODB.Recordset
Rs.Open Cible, xConnect, adOpenStatic, adLockOptimistic, adCmdText

If Not Rs.EOF Then
For i = 1 To UBound(Tableau)
If Rs.RecordCount >= Tableau(i) - NumRec Then
Rs.Move Tableau(i) - NumRec
Cells(j, i) = Rs.Fields(0).Value
NumRec = Tableau(i)
End If
Next i
End If

Cn.Close
Rs.Close
Set Cn = Nothing
Set Rs = Nothing
End If

Fichier = Dir()
Loop

End Sub


Merci de votre aide

@+
 
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Re : Manip sur cellules fichiers fermes

Re,

Je comprends que les numéros ne se suivent pas, ils sont quelconques, c'est dommage car ça aurait facilité la tâche.

Quid de la formule avec le chemin d'accès ?

Ou alors : le dossier des fichiers à copier est-il le même que celui du fichier de requête ?

A+
 
Vote positif 0 Vote négatif
V

VBANOVICE

XLDnaute Junior
Re : Manip sur cellules fichiers fermes

michel_m à dit:
Re, vbanovice, Bonsoir Job75

Comme tu as peu de cellules à transfèrer, tu pourrais utiliser la macroXL4 dite Walkenbach. Tu en trouveras une proposition récente:
https://www.excel-downloads.com/threads/recuperation-de-donnees-dun-classeur-ferme.122241/
tes cellules étant disjointes sur tes classeurs source, l'utilisation de SQL et d'ADO, la plus rapide, serait assez compliquée dans ce cas.

pour parcourir le répertoire de tes 400 classeurs (400 fichiers à extraire, ca me dit quelque chose sur un autre site ,mais...), je viens de te fournir la méthode dans le post sur l'impression; donc il sufira d'imbriquer avec la macro ci dessus param^trée au nom du fichier en cours
Cliquez pour agrandir...


oups j'avais zappe le lien
je test et te tient au courrant

pour l'autre site je pensais avoir plus de chance d'avoir une info en posant la question sur un autre forum , mais si cela n'est pas utile je reste sur excel download
cordialement
 
Vote positif 0 Vote négatif
jeanpierre

jeanpierre

Nous a quitté
Repose en paix
Re : Manip sur cellules fichiers fermes

Bonjour michel_m, job, VBANOVICE,

Le problème n'est pas tant que tu aies poser la question ailleurs, mais surtout de nous l'indiquer, même mieux de donner le lien afin que chacun puisse suivre les réponses données, ici et ailleurs, en connaissance de cause et surtout de ne pas travailler pour rien.

Voilà pour moi.

Bon après-midi.

Jean-Pierre
 
Vote positif 0 Vote négatif
V

VBANOVICE

XLDnaute Junior
Re : Manip sur cellules fichiers fermes

jeanpierre à dit:
Bonjour michel_m, job, VBANOVICE,

Le problème n'est pas tant que tu aies poser la question ailleurs, mais surtout de nous l'indiquer, même mieux de donner le lien afin que chacun puisse suivre les réponses données, ici et ailleurs, en connaissance de cause et surtout de ne pas travailler pour rien.

Voilà pour moi.

Bon après-midi.

Jean-Pierre
Cliquez pour agrandir...

bonjour jean pierre

si j'ai compris pour ma demande je suis bani du site?
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Manip sur cellules fichiers fermes

Re, salut jeanpierre,

Je vais devoir m'absenter, alors voici la macro.

Elle suppose que le dossier des fichiers copiés est le même que celui du fichier contenant la macro, et que les feuilles copiées s'appellent toutes "Feuil1".

Si ce n'est pas le cas, modifier les variables chemin et feuil.

Code: 
Sub CopierFichiers()
Dim lig%, chemin$, formul$, feuil$, nomfich$, txt$
Range("C14:J1000").ClearContents  'effacement de la zone de copie
Application.ScreenUpdating = False
lig = 14
chemin = ThisWorkbook.Path 'chemin d'accès du dossier
formul = "='" & chemin & "\["
feuil = "]Feuil1'!" 'Feuil1 = nom de la feuille copiée
nomfich = Dir(chemin & "\*.xls") '1er fichier du dossier
While nomfich <> ""
  If nomfich <> ThisWorkbook.Name Then
    txt = formul & nomfich & feuil
    Range("C" & lig).FormulaLocal = txt & "D5"
    Range("D" & lig).FormulaLocal = txt & "D6"
    Range("E" & lig).FormulaLocal = txt & "D7"
    Range("F" & lig).FormulaLocal = txt & "D8"
    Range("G" & lig).FormulaLocal = txt & "M6"
    Range("H" & lig).FormulaLocal = txt & "M7"
    Range("I" & lig).FormulaLocal = txt & "M9"
    Range("J" & lig).FormulaLocal = txt & "M10"
    lig = lig + 1
  End If
  nomfich = Dir 'fichier suivant du dossier
Wend
Range("C14:J1000") = Range("C14:J1000").Value 'suppression des formules
End Sub

A+
 
Dernière édition:
Vote positif 0 Vote négatif
jeanpierre

jeanpierre

Nous a quitté
Repose en paix
Re : Manip sur cellules fichiers fermes

Re,

Non, tu n'as rien compris. Ici on ne bannie pas.

Simplement que d'indiquer dans le fil, comme je l'ai dit, tes questions posées ailleurs et les liens, au besoin permettent à chacun de pouvoir travailler en connaissance de cause et surtout ne pas faire doublons avec d'autres réponses, ici ou ailleurs.

Suis-je plus clair ?
 
Vote positif 0 Vote négatif
V

VBANOVICE

XLDnaute Junior
Re : Manip sur cellules fichiers fermes

job75 à dit:
Re, salut jeanpierre,

Je vais devoir m'absenter, alors voici la macro.

Elle suppose que le dossier des fichiers copiés est le même que celui du fichier contenant la macro, et que les feuilles copiées s'appellent toutes "Feuil1".

Si ce n'est pas le cas, modifier les variables chemin et feuil.

Code: 
Sub CopierFichiers()
Dim lig%, chemin$, formul$, feuil$, nomfich$, txt$
Range("C14:J1000").ClearContents  'effacement de la zone de copie
Application.ScreenUpdating = False
lig = 14
chemin = ThisWorkbook.Path 'chemin d'accès du dossier
formul = "='" & chemin & "\["
feuil = "]Feuil1'!" 'Feuil1 = nom de la feuille copiée
nomfich = Dir(chemin & "\*.xls") '1er fichier du dossier
While nomfich <> ""
  If nomfich <> ThisWorkbook.Name Then
    txt = formul & nomfich & feuil
    Range("C" & lig).FormulaLocal = txt & "D5"
    Range("D" & lig).FormulaLocal = txt & "D6"
    Range("E" & lig).FormulaLocal = txt & "D7"
    Range("F" & lig).FormulaLocal = txt & "D8"
    Range("G" & lig).FormulaLocal = txt & "M6"
    Range("H" & lig).FormulaLocal = txt & "M7"
    Range("I" & lig).FormulaLocal = txt & "M9"
    Range("J" & lig).FormulaLocal = txt & "M10"
    lig = lig + 1
  End If
  nomfich = Dir 'fichier suivant du dossier
Wend
Range("C14:J1000") = Range("C14:J1000").Value 'suppression des formules
End Sub

A+
Cliquez pour agrandir...


:p merci je test de suite la macro et done des nouvelles
 
Vote positif 0 Vote négatif
V

VBANOVICE

XLDnaute Junior
Re : Manip sur cellules fichiers fermes

jeanpierre à dit:
Re,

Non, tu n'as rien compris. Ici on ne bannie pas.

Simplement que d'indiquer dans le fil, comme je l'ai dit, tes questions posées ailleurs et les liens, au besoin permettent à chacun de pouvoir travailler en connaissance de cause et surtout ne pas faire doublons avec d'autres réponses, ici ou ailleurs.

Suis-je plus clair ?
Cliquez pour agrandir...

:eek: oui a bientot et j'espere que michel_m n'est pas faché et qu'il pourra me doner la macro sur impression

@+
 
Vote positif 0 Vote négatif
V

VBANOVICE

XLDnaute Junior
Re : Manip sur cellules fichiers fermes

job75 à dit:
Re, salut jeanpierre,

Je vais devoir m'absenter, alors voici la macro.

Elle suppose que le dossier des fichiers copiés est le même que celui du fichier contenant la macro, et que les feuilles copiées s'appellent toutes "Feuil1".

Si ce n'est pas le cas, modifier les variables chemin et feuil.

Code: 
Sub CopierFichiers()
Dim lig%, chemin$, formul$, feuil$, nomfich$, txt$
Range("C14:J1000").ClearContents  'effacement de la zone de copie
Application.ScreenUpdating = False
lig = 14
chemin = ThisWorkbook.Path 'chemin d'accès du dossier
formul = "='" & chemin & "\["
feuil = "]Feuil1'!" 'Feuil1 = nom de la feuille copiée
nomfich = Dir(chemin & "\*.xls") '1er fichier du dossier
While nomfich <> ""
  If nomfich <> ThisWorkbook.Name Then
    txt = formul & nomfich & feuil
    Range("C" & lig).FormulaLocal = txt & "D5"
    Range("D" & lig).FormulaLocal = txt & "D6"
    Range("E" & lig).FormulaLocal = txt & "D7"
    Range("F" & lig).FormulaLocal = txt & "D8"
    Range("G" & lig).FormulaLocal = txt & "M6"
    Range("H" & lig).FormulaLocal = txt & "M7"
    Range("I" & lig).FormulaLocal = txt & "M9"
    Range("J" & lig).FormulaLocal = txt & "M10"
    lig = lig + 1
  End If
  nomfich = Dir 'fichier suivant du dossier
Wend
Range("C14:J1000") = Range("C14:J1000").Value 'suppression des formules
End Sub

A+
Cliquez pour agrandir...

:):p merci pour ton aide cette macro fonctionne à merveille et est adaptable si j'ai d'autres cellules a copier

a bientot
 
Vote positif 0 Vote négatif

Discussions similaires

B
  • Question
XL 2016 Propriétés fichiers vidéos.
Réponses
3
Affichages
220
patricktoulon
patricktoulon
T
  • Question
Microsoft 365 Ouvrir un fichier en fonction de sa date
Réponses
1
Affichages
141
sylvanu
sylvanu
F
  • Question
XL 2019 erreur 1004
Réponses
8
Affichages
228
florian50470
F
halecs93
  • Question
Microsoft 365 Générer mail via Excel
Réponses
2
Affichages
216
halecs93
halecs93
O
  • Question
Microsoft 365 Excel [VBA]. Erreur d’exécution 424 Objet requis sur une concaténation
Réponses
3
Affichages
141
Oneida
Oneida
Y
  • Question
Microsoft 365 Publipostage automatique de plusieurs fichiers word à partir d'excel
Réponses
6
Affichages
413
yannlion
Y
L
  • Question
Microsoft 365 vba Outlook traiter un fichier excel lors de sa reception
Réponses
0
Affichages
257
lesoldat9
L
G
  • Question
Microsoft 365 Saut de ligne dans une cellule
Réponses
3
Affichages
130
GClaire
G
L
  • Question
Autres Copier des données d’un fichier sans l’ouvrir juste en le sélectionnant via un UserForm
Réponses
6
Affichages
404
Liner77
L
I
  • Question
Microsoft 365 Renommer des fichiers avec des caractères non reconnus
Réponses
10
Affichages
430
ivan27
I

Membres actuellement en ligne

21 membres et 266 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 158
Messages
2 085 831
Membres
102 996
dernier inscrit
Zabouille73