Recherche d'un fichier et extraction des données

henrylandes · 4 Juin 2011

Bonjour,
Gros problème.
J’ai deux fichiers : Tableau bilan questionnaire ET Questionnaire satisfaction

Je voudrai rechercher le questionnaire de satisfaction dans un dossier bien précis et recopier les données de ce fichier dans le Tableau bilan questionnaire. Bien entendu recopier les informations dans la dernière ligne vide. Pour ça j’ai réussi à créer ce code (voir ci-après) mais il ne fonctionne pas puisqu’il me met « fichier absent ».😕

Je joins un fichier word explicatif.

Code:

Private Sub CommandButton1_Click()
Dim Wb As Workbook
Feuil1.Select  'Feuil1(nom de gauche en projet)
Chemin = "C:\WINDOWS\Web\" 'chemin où se trouve les fichiers'
Fichier = TextBox1.Text & ".xls"
On Error Resume Next
Set Wb = GetObject(Chemin & Fichier)
If Err <> 0 Then MsgBox "Fichier Absent": Exit Sub
With Wb.Sheets("Feuil1") 'Nom de la feuille du questionnaire de satisfaction'
For k = 6 To .[A65536].End(3).Row
If .Range("A" & k) <> "" Then
lig = [I65536].End(3).Row + 1
Range("A" & lig).Value = .TextBox4.Value
Range("B" & lig).Value = .TextBox5.Value
Range("C" & lig).Value = .IIf(.Range("F20" & k).Value = "x", "1", IIf(.Range("G20" & k).Value = "x", "0", IIf(.Range("H20" & k).Value = "x", "-1", "/")))
Range("D" & lig).Value = .IIf(.Range("F21" & k).Value = "x", "1", IIf(.Range("G21" & k).Value = "x", "0", IIf(.Range("H21" & k).Value = "x", "-1", "/")))
Range("D" & lig).Value = .IIf(.Range("F22" & k).Value = "x", "1", IIf(.Range("G22" & k).Value = "x", "0", IIf(.Range("H22" & k).Value = "x", "-1", "/")))
If Range("I20") <> "" Then Res = 1 & Range("I20")
If Range("I21") <> "" Then Res = Res & 2 & Range("I21")
If Range("I22") <> "" Then Res = Res & 3 & Range("I22")
Range("L6") = Res
End If
Next
End With

Wb.Close
End Sub

Merci à vous.

henrylandes · 13 Juin 2011

Re : Recherche d'un fichier et extraction des données

Bonjour et merci Bebere,

J'ai intégré le code et celui-ci répond à mes attentes.😉

Mille merci pour ta patience et ta disposition.

Je clôture ce post. Ci-joint le code final qui est intégré au bonton OK du userform1 de ma 1ère feuille.
Code vba pour extraction et concatener cellule • Excel-Pratique

Code:

Private Sub CommandButton1_Click()
Dim Wb As Workbook, Ws As Worksheet
'Feuil1.Select 'Feuil1(nom de gauche en projet)
Chemin = "C:\WINDOWS\Web\" 'chemin où se trouve les fichiers'
Fichier = TextBox1.Text & ".xlsx" 'attention à l'extension
On Error Resume Next
Set Wb = Workbooks.Open(Filename:=Chemin & Fichier)
If Err <> 0 Then MsgBox "Fichier Absent": Exit Sub
With Wb.Sheets("Feuil1") 'Nom de la feuille du questionnaire de satisfaction'

If .Range("D5") Like "*audit*" Or "*responsable audit*" Then
nomf = "Audit interne"
End If

If .Range("D5") Like "Bénéficiaire" Then
nomf = "Bénéficiaire"
End If
Set Ws = ThisWorkbook.Worksheets(nomf)
lig = Ws.[A65536].End(3).Row + 1

Ws.Range("A" & lig).Value = .TextBox4.Value
Ws.Range("B" & lig).Value = .TextBox5.Value
For k = 20 To 28
Select Case k
Case 20
If .Range("F" & k).Value = "x" Then
Ws.Range("C" & lig).Value = 1
ElseIf .Range("G" & k).Value = "x" Then
Ws.Range("C" & lig).Value = 0
ElseIf .Range("H" & k).Value = "x" Then
Ws.Range("C" & lig).Value = -1
Else
Ws.Range("C" & lig).Value = "/"
End If
If .Range("I" & k) <> "" Then Ws.Range("L" & lig) = .Range("A" & k) & .Range("I" & k)

Case 21
If .Range("F" & k).Value = "x" Then
Ws.Range("D" & lig).Value = 1
ElseIf .Range("G" & k).Value = "x" Then
Ws.Range("D" & lig).Value = 0
ElseIf .Range("H" & k).Value = "x" Then
Ws.Range("D" & lig).Value = -1
Else
Ws.Range("D" & lig).Value = "/"
End If
If .Range("I" & k) <> "" Then Ws.Range("L" & lig) = Ws.Range("L" & lig) & " " & .Range("A" & k) & .Range("I" & k)

Case 22
If .Range("F" & k).Value = "x" Then
Ws.Range("E" & lig).Value = 1
ElseIf .Range("G" & k).Value = "x" Then
Ws.Range("E" & lig).Value = 0
ElseIf .Range("H" & k).Value = "x" Then
Ws.Range("E" & lig).Value = -1
Else
Ws.Range("E" & lig).Value = "/"
End If
If .Range("I" & k) <> "" Then Ws.Range("L" & lig) = Ws.Range("L" & lig) & " " & .Range("A" & k) & .Range("I" & k)

Case 23
If .Range("F" & k).Value = "x" Then
Ws.Range("F" & lig).Value = 1
ElseIf .Range("G" & k).Value = "x" Then
Ws.Range("F" & lig).Value = 0
ElseIf .Range("H" & k).Value = "x" Then
Ws.Range("F" & lig).Value = -1
Else
Ws.Range("F" & lig).Value = "/"
End If
If .Range("I" & k) <> "" Then Ws.Range("L" & lig) = Ws.Range("L" & lig) & " " & .Range("A" & k) & .Range("I" & k)

Case 24
If .Range("F" & k).Value = "x" Then
Ws.Range("G" & lig).Value = 1
ElseIf .Range("G" & k).Value = "x" Then
Ws.Range("G" & lig).Value = 0
ElseIf .Range("H" & k).Value = "x" Then
Ws.Range("G" & lig).Value = -1
Else
Ws.Range("G" & lig).Value = "/"
End If
If .Range("I" & k) <> "" Then Ws.Range("L" & lig) = Ws.Range("L" & lig) & " " & .Range("A" & k) & .Range("I" & k)

Case 25
If .Range("F" & k).Value = "x" Then
Ws.Range("H" & lig).Value = 1
ElseIf .Range("G" & k).Value = "x" Then
Ws.Range("H" & lig).Value = 0
ElseIf .Range("H" & k).Value = "x" Then
Ws.Range("H" & lig).Value = -1
Else
Ws.Range("H" & lig).Value = "/"
End If
If .Range("I" & k) <> "" Then Ws.Range("L" & lig) = Ws.Range("L" & lig) & " " & .Range("A" & k) & .Range("I" & k)

Case 26
If .Range("F" & k).Value = "x" Then
Ws.Range("I" & lig).Value = 1
ElseIf .Range("G" & k).Value = "x" Then
Ws.Range("I" & lig).Value = 0
ElseIf .Range("H" & k).Value = "x" Then
Ws.Range("I" & lig).Value = -1
Else
Ws.Range("I" & lig).Value = "/"
End If
If .Range("I" & k) <> "" Then Ws.Range("L" & lig) = Ws.Range("L" & lig) & " " & .Range("A" & k) & .Range("I" & k)

Case 27
If .Range("F" & k).Value = "x" Then
Ws.Range("J" & lig).Value = 1
ElseIf .Range("G" & k).Value = "x" Then
Ws.Range("J" & lig).Value = 0
ElseIf .Range("H" & k).Value = "x" Then
Ws.Range("J" & lig).Value = -1
Else
Ws.Range("J" & lig).Value = "/"
End If
If .Range("I" & k) <> "" Then Ws.Range("L" & lig) = Ws.Range("L" & lig) & " " & .Range("A" & k) & .Range("I" & k)

Case 28
If .Range("F" & k).Value = "x" Then
Ws.Range("K" & lig).Value = 1
ElseIf .Range("G" & k).Value = "x" Then
Ws.Range("K" & lig).Value = 0
ElseIf .Range("H" & k).Value = "x" Then
Ws.Range("K" & lig).Value = -1
Else
Ws.Range("K" & lig).Value = "/"
End If
If .Range("I" & k) <> "" Then Ws.Range("L" & lig) = Ws.Range("L" & lig) & " " & .Range("A" & k) & .Range("I" & k)

End Select
Next
End With

Wb.Close False

End Sub

henrylandes · 14 Juin 2011

Re : Recherche d'un fichier et extraction des données

Bonjour le forum,

Oups j'ai oublié d'intégrer une info de plus dans mon code.

En fait je voudrai extraire le contenu d'un textbox présent dans le fichier intitulé Questionnaire de satisfaction pour l'intégrer dans la colonne L du fichier intitulé Tableau bilan questionnaire.

J'ai mis ce code en début

Code:

Ws.Range("L" & lig).Value = .TextBox2.Value

ça ne marche pas et il ne m'affiche aucune erreur.

J'ai opté pour une seconde solution en mettant ce code à la fin

Code:

If .TextBox2.Value <> "" Then Ws.Range("L" & lig) = Ws.Range("L" & lig) & " "

ça ne marche pas et toujours pas d'erreur qui s'affiche.

Mon code complet a été posté précédemment.

Merci de votre aide.

Bebere · 15 Juin 2011

Re : Recherche d'un fichier et extraction des données

bonjour Henrylandes
si tu veux en début de chaîne
place la ligne avant for k=20 to 28
If .TextBox2.Value <> "" Then Ws.Range("L" & lig) = .TextBox2.Value
si à la fin avant end with
If .TextBox2.Value <> "" Then Ws.Range("L" & lig) =Ws.Range("L" & lig) & " " & .TextBox2.Value
textbox2 doit exister
à bientôt

henrylandes · 15 Juin 2011

Re : Recherche d'un fichier et extraction des données

Bonjour Bebere,

Génial comme quoi si j'avais réfléchi plus longtemps j'aurai peut être trouvé. Mais je garde précieusement ce programme qui m'aidera certainement une autre fois.

Encore merci.

Ce post est désormais définitivement clos.

Cordialement.

Recherche d'un fichier et extraction des données

henrylandes

XLDnaute Nouveau

Pièces jointes

henrylandes

XLDnaute Nouveau

henrylandes

XLDnaute Nouveau

Bebere

XLDnaute Barbatruc

henrylandes

XLDnaute Nouveau

Discussions similaires

Recherche d'un fichier et extraction des données

henrylandes

XLDnaute Nouveau

Pièces jointes

henrylandes

XLDnaute Nouveau

henrylandes

XLDnaute Nouveau

Bebere

XLDnaute Barbatruc

henrylandes

XLDnaute Nouveau

Discussions similaires

Privacy & Transparency

Privacy & Transparency