Extraction matricielle
Bonjour ,
je cherche à avoir une extraction automatique d'une valeur de cellule, mais sous forme matricielle. Les cellulles P1 des feuille T9600, T9660, X1450 doivent étre inscrite dans la premiére colone de la feuille extraction à partir de la cellule A5.
Le code VBA est dans la fichier extraction.
Dans le fichier Extraction, vous mettez le chemin en F1 le chemin ou sont contenus les fichier T9600; T9660 et X1450.
Dans le fichier Extraction, vous laissez la feuille Fich_isol dans la cellule F2
Merçi d'avance pour votre aide.
.Mes Salutations.
Bonjour,
Il va falloir que tu donnes un peu plus d'explications !
Bonjour,
Il va falloir que tu donnes un peu plus d'explications !
Bonjour Theze,
la macro lit les fichiers T9600, T9660 et X1450. tu télécharges et tu places ces 3 fichiers dans un dossier, ensuite tu télécharges le fichier extraction (emplacement bureau), tu copies colles le chemin dans la cellule F1 du fichier extraction, tu conserves Fich_Isol dans la cellule F2.
Sauf que la colonne A du fichier extraction me donne le nom des fichiers, et je cherche à extraire les valeurs des celulles P1 des fichiers T9600, T9660 et X1450 et les inclure à partir de A5 du fichier Extraction.
Restant à ta disposition.
Mes amitiés.
Sub EXTRACT_xxxxxx()
'--- methode avec ouverture fichier plus rapide ---
'--- extract des données joints et bribes pleines ---
Dim intCount As Integer
Dim strSavedDir As String
Dim strFile As String, app As String, ot As String
Dim strsheet As String
Dim strCopy As String
Dim matrice(5000, 14) As String
Dim grech As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
On Error Resume Next
strSavedDir = Range("F1")
If Right(strSavedDir, 1) <> "\" Then
strSavedDir = strSavedDir & "\"
End If
v = -1
lmin = 6 'premiere ligne de copie dans f
crech = 8 'colonne de recherche de lmax
grech = Cells(1, 4)
classeur = ActiveWorkbook.Name
strsheet = Range("F2")
strFile = Dir(strSavedDir & grech) 'recherche
Do While strFile <> ""
Workbooks.Open Filename:=strSavedDir & strFile, UpdateLinks:=0, ReadOnly:=True
intCount = intCount + 1
Application.StatusBar = intCount & ": " & strFile
sh = Sheets.Count
For i = 1 To sh
strsheet = "*" & strsheet & "*"
If Sheets(i).Name Like strsheet Then
Sheets(i).Activate
inc = lmin
j = inc
Do While Cells(j, crech) <> "" Or Cells(j + 1, crech) <> ""
If Cells(j, crech) <> "" And Cells(j, crech) <> 0 Then
v = v + 1
matrice(v, 0) = Left(strFile, Len(strFile) - 31) ''''''''''''''''''''''''' Afficher les valeurs de P1 des fichiers T9600,T9660 et X1450
matrice(v, 1) = Cells(j, crech).Value
matrice(v, 2) = Cells(j, crech + 1).Value
matrice(v, 3) = Cells(j, crech + 4).Value
matrice(v, 4) = Cells(j, crech + 5).Value
matrice(v, 5) = Cells(j, crech + 6).Value
matrice(v, 6) = Cells(j, crech + 7).Value
matrice(v, 7) = Cells(j, crech + 8).Value
matrice(v, 8) = Cells(j, crech + 9).Value
matrice(v, 9) = Cells(j, crech + 10).Value
matrice(v, 10) = Cells(j, crech + 11).Value
matrice(v, 11) = Cells(j, crech + 13).Value
matrice(v, 12) = Cells(j, crech + 14).Value
matrice(v, 13) = Cells("P" & 1).Value
End If
j = j + 1
Loop
End If
Next i
Workbooks(strFile).Close
strFile = Dir
Loop
'--- efface la plage ---------------------------------------
[5:5000].ClearContents
[5:5000].ClearFormats
[5:5000].ClearFormats
Range([A5], [i5000]).UnMerge
'--- Copie des donnees --------------------------------------
Workbooks(classeur).Activate
For w = 0 To v ' --- copie des valeurs