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

N
  • Question
Microsoft 365 Code VBA
Réponses
7
Affichages
592
TooFatBoy
TooFatBoy
Nicolas JACQUIN
  • Résolu(e)
XL 2021 Aide adaptation code vba pour complément
Réponses
7
Affichages
272
Nicolas JACQUIN
Nicolas JACQUIN
G
  • Question
XL 2016 Extraire des données d'un pdf et les copier dans excel
2
Réponses
17
Affichages
820
gali2
G
P
  • Question
XL 2019 Changer nom d'export en VBA
Réponses
3
Affichages
483
job75
job75
S
  • Question
XL 2010 Connection avec autre feuille excel et insertion
Réponses
5
Affichages
809
dysorthographie
dysorthographie
R
  • Résolu(e)
Microsoft 365 Extraction contenu mail outlook vers excel
2
Réponses
18
Affichages
1 K
raf26
R
F
  • Question
Microsoft 365 Problème avec VBA ( Résolu)
Réponses
2
Affichages
301
firecarl
F
patricktoulon
  • Question
Autres la fonction similaire
Réponses
11
Affichages
433
patricktoulon
patricktoulon
A
  • Résolu(e)
XL 2021 Céer un fichier (.text) avec VBA pour enregistrer les évènements dans un journal
Réponses
4
Affichages
465
arnoldbrice19
A
P
  • Question
Microsoft 365 Problème lors de la création d'un fichier
Réponses
4
Affichages
378
ChTi160
ChTi160

Membres actuellement en ligne

Aucun membre en ligne actuellement.
1 membres et 60 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
315 097
Messages
2 116 186
Membres
112 679
dernier inscrit
Yupanki