Code VBA pour extraction et concatener cellule

Le 11/06/2011 à 19:19

Boujour,

j'ai deux fichiers : Tableau bilan questionnaire et Questionnaire satisfaction

L'objectif est d'extraire des données du Questionnaire satisfaction vers le Tableau bilan questionnaire. Pour cela le code ci-dessous fonctionne mais je voudrai y rajouter la condition suivante :

L (cellule du TableauBilanQuestionnairesTest) = à I20 (cellule du questionnaire satisfaction) si <>"" et A20 +
I21 si <> "" et A21 + I22 si <>"" et A22 + I23 <>"" et A23 + I24 <>"" et A24 + I25 <>"" et A25 + I26 <>"" et A26 + I27 <>"" et A27 + I28 <>"" et A28 + I29 <>"" et A29.

que j'ai traduire en une seule ligne en code VBA comme suit :

If .Range("I" & k) <> "" Then Ws.Range("L" & lig) = .Range("A" & k) & .Range("I" & k)
End If

Mais ça ne fonctionne pas car il ne tient compte que de la dernière cellule complétée et non des autres.

Voici le code au complet qui fonctionne en grande partie sauf la dernière ligne de ce code et qui est reprise ci-dessus:

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
Set Ws = ThisWorkbook.Worksheets("Feuil1")
lig = Ws.[A65536].End(3).Row + 1
With Wb.Sheets("Feuil1") 'Nom de la feuille du questionnaire de satisfaction'
For k = 6 To .[A65536].End(3).Row
Ws.Range("A" & lig).Value = .TextBox4.Value
Ws.Range("B" & lig).Value = .TextBox5.Value

If .Range("A" & k) <> "" And IsNumeric(.Range("A" & k)) Then 'changé
Select Case Left(.Range("A" & k), 1)
Case 1
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
Case 2
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
Case 3
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
Case 4
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
Case 5
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
Case 6
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
Case 7
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
Case 8
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
Case 9
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
End Select
If .Range("I" & k) <> "" Then Ws.Range("L" & lig) = .Range("A" & k) & .Range("I" & k)
End If
Next
End With
Wb.Close False
End Sub
Le 11/06/2011 à 20:30

Re henrylandes le forum

et de 3 forums pour la même question !!!!!

Franchement tu trouves cela bien et respectable pour les gens qui cherchent à t'aider??

a+

papou

Le 11/06/2011 à 20:50

Re Paritec,

je sais je suis impardonnable mais je pense que toutes les solutions sont bonnes surtout si on clôture correctement tous les sujets.

Pour revenir à mon sujet, je joins le code complet.

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
Set Ws = ThisWorkbook.Worksheets("Feuil1")
lig = Ws.[A65536].End(3).Row + 1
With Wb.Sheets("Feuil1") 'Nom de la feuille du questionnaire de satisfaction'
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
Le 11/06/2011 à 20:52

Re henrylandes le forum

bon alors si tu le prends comme cela OK , mais quand même c'est mieux si tu le dis en postant

a+

papou

Rechercher des sujets similaires à "code vba extraction concatener"