1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
|
Public Function setReturnReponse(noQs As String, lbStrQr As String, strChronoR As String, valNbChoix As Integer, tbReponse As Variant) As Boolean
Dim ObjRange As Object
Dim ObjPrio As Object
Dim valRowCourant As Integer
Dim valRowAncien As Integer
Dim strLUbReponse As Variant
Dim cpt As Integer
cpt = 0
valRowCourant = 0
valRowAncien = 0
'Si il n'y a pas d'élèments on ne fait rien
If IsArray(tbReponse) = False Then
setReturnReponse = False
Exit Function
End If
If UBound(tbReponse) <> 0 Then
'xlBook.Worksheets(2).Cells(1, 1).Select
'MsgBox lbStrQr
If xlBook Is Nothing Then
lbQr = lbStrQr
'Set xlBook = xlApp.Workbooks("c:\temp\tempqcmxls.xls")
Call setOpenSession
MsgBox "Instancié"
End If
'MsgBox "Numéro de Question :" & noQs
With xlBook
'.Worksheets(lbStrQr).Activate
.ActiveSheet.Cells(1, 1).Select
'Recherche no question A:A
With .Worksheets(lbStrQr).Columns("A:A")
.Find(What:="" & noQs & "", _
LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
End With
'Inserer la valeur du chronométre E:E
valRowCourant = ActiveCell.Row
valRowAncien = valRowCourant
'.Worksheets(lbStrQr).Cells(valRowCourant, 5).Value = strChronoR
'.Worksheets(2).Cells(valRowAncien, 2).Select
'MsgBox "Chrono fait:" & UBound(tbReponse)
'Calcule pour definir la plage de recherche
valNbChoix = valNbChoix + valRowAncien
'Recherche lbreponse B:B
For cpt = 0 To UBound(tbReponse)
.Worksheets(lbStrQr).Cells(valRowAncien, 2).Activate
If tbReponse(cpt) <> "" Then
strLUbReponse = Mid(tbReponse(cpt), 1, _
InStr(1, tbReponse(cpt), "|") - 1)
'Si rien n'a été sélectionné =R
'on ne rentre
If strLUbReponse <> "R" Then
Set ObjRange = .Worksheets(lbStrQr).Range("B" & CStr(valRowAncien) & ":B" & CStr(valNbChoix) & "")
'Set ObjRange = .ActiveSheet.Range(Cells(valRowAncien, 2), Cells(valNbChoix, 2)).Cells
If ObjRange Is Nothing Then
MsgBox "ObjRange Non instancié"
Set ObjRange = Nothing
Set ObjPrio = Nothing
setReturnReponse = False
Exit Function
'Else
' ObjRange.Activate
End If
Set ObjPrio = ObjRange.Cells.Find(What:=CStr(strLUbReponse), _
After:=ActiveCell, _
LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If ObjPrio Is Nothing Then
MsgBox "ObjPrio Non instancié"
Set ObjRange = Nothing
Set ObjPrio = Nothing
setReturnReponse = False
Exit Function
Else
ObjPrio.Activate
End If
'MsgBox
'Inserer la valeur réponse user D:D
valRowCourant = ActiveCell.Row
MsgBox valRowCourant
'Si le contenue du tableau (OUI) = Contenu de la cell (OUI)
' inscrire valeur
If Trim(strLUbReponse) = Trim(CStr(.Worksheets(2).Cells(valRowCourant, 2).Value)) Then
'MsgBox Mid(tbReponse(cpt), InStr(1, tbReponse(cpt), "|") + 1, 1) & ":valCell>" & CStr(.Worksheets(2).Cells(valRowCourant, 2).Value)
.Worksheets(lbStrQr).Cells(valRowCourant, 4).Value = Mid(tbReponse(cpt), _
InStr(1, tbReponse(cpt), "|") + 1, _
1)
'MsgBox "reponseU>" & strLUbReponse & ":valCell>" & CStr(.Worksheets(2).Cells(valRowCourant, 2).Value)
'MsgBox tbReponse(cpt) & "-tbReponse/" & valRowAncien & "-RA / " & valRowCourant & "-RC/ valCell = " & CStr(.Worksheets(2).Cells(valRowCourant, 4).Value)
End If
End If
End If
Next
.Save
End With
End If
'If Err.Number <> 0 And Err.Number <> 91 Then
' MsgBox Err.Number
' GoTo ERR_OnSetReturnReponse
'End If
Set ObjRange = Nothing
Set ObjPrio = Nothing
'MsgBox "Fin True"
setReturnReponse = True
'ERR_OnSetReturnReponse:
' MsgBox "Fin False"
' setReturnReponse = False
End Function |
