Hallo Sebastian,
vielleicht hilft Dir mein Auswertungsprogramm für zwei Psycho-Tests ....
Gruß
Peter
Dim skala(14) As Integer
Dim skalenname(16) As String
Dim Sten(16) As Integer
Sub SCLRohwertezählen()
Nr1% = Sheets("Befehle").Range("B7") 'erste und letzte Spalte, die auszuwerten sind
Nr2% = Sheets("Befehle").Range("B8") '.Cells(2, 1)
For z% = Nr1% To Nr2%
For sp% = 1 To 90
D% = Sheets("SCLDaten2").Range("SCLRohDaten").Cells(z%, sp%).Value 'summiert die Rohdaten zu Skalensummenwerten
sk% = Sheets("Pssi-Polung").Range("ZuSkala").Cells(sp%, 1).Value
skala(sk%) = skala(sk%) + D%
'GSI% = GSI% + skala(sk%)
Next sp%
For sp% = 1 To 10 'schreibt die Summenwerte auf
Sheets("SCLDaten2").Range("SCLSummen").Cells(z%, sp%) = skala(sp%)
GSI% = GSI% + skala(sp%)
skala(sp%) = 0
Next sp%
Sheets("SCLDaten2").Range("SCLSummen").Cells(z%, 11) = GSI%
GSI% = 0
Next z%
End Sub
Sub TWerteBerechnen()
za% = Sheets("Befehle").Range("B7") 'erste und letzte Spalte, die auszuwerten sind
zo% = Sheets("Befehle").Range("B8")
'Y% = Range("RohDaten").Cells(20, 1)
For z% = za% To zo%
If Sheets("SCLDaten2").Range("B3:I80").Cells(z%, 4) = "w" Then N$ = "NormenFrauen"
If Sheets("SCLDaten2").Range("B3:I80").Cells(z%, 4) = "m" Then N$ = "NormenMänner"
'Range("SCLDaten!C137").Value = N$
For sp% = 1 To 9
skala(sp%) = Sheets("SCLDaten2").Range("SCLSummen").Cells(z%, sp%)
Next sp%
skala(10) = Sheets("SCLDaten2").Range("SCLSummen").Cells(z%, 11) 'der GSI-Wert der nach dem 'Zusatz' kommt
For I% = 1 To 10 'T-Wert finden
1 zähl% = zähl% + 1
x% = Sheets("SCLNormen").Range(N$).Cells(zähl%, 1) 'der Summenwert aus der Normentabelle
If skala(I%) > x% Then GoTo 1
'Range("TWerte").Cells(z%, sp%) = Range(N$).Cells(zähl%, z% + 1)
Sheets("Ergebnisse").Range("SCL_T_Werte").Cells(z%, I%) = Sheets("SCLNormen").Range(N$).Cells(zähl%, I% + 1)
zähl% = 0
Next I%
For I% = 1 To 8
Sheets("Ergebnisse").Range("B3:I80").Cells(z%, I%) = Sheets("SCLDaten2").Range("B3:I80").Cells(z%, I%)
Next I%
Next z%
For z% = 1 To 11 'falls die Werte noch mal berechnet werden
skala(z%) = 0
Next z%
End Sub
Sub PssiRohwerteBerechnen()
z1% = Sheets("Befehle").Range("B24") 'erste und letzte Zeile, die auszuwerten sind
z2% = Sheets("Befehle").Range("B25") '.Cells(2, 1) evtl.: z2% = Sheets("Befehle").Range("B25").Value
For z% = z1% To z2%
For sp% = 1 To 140 'summierung der skalen-rohwerte
D% = Sheets("PSSi-DatenT").Range("PssiDaten").Cells(z%, sp%).Value 'summiert die Rohdaten zu Skalensummenwerten
sk% = Sheets("Pssi-Polung").Range("PssiPolung").Cells(sp%, 2).Value
If Sheets("Pssi-Polung").Range("PssiPolung").Cells(sp%, 3).Value = "u" Then
x% = D% - 3
D% = Abs(x%)
End If
skala(sk%) = skala(sk%) + D%
Next sp%
For I% = 1 To 14 'schreibt die Summenwerte auf
Sheets("PSSi-DatenT").Range("PssiRohwerte").Cells(z%, I%) = skala(I%)
skala(I%) = 0
Next I%
Next z%
End Sub
Sub PSSiTWerteBerechnen()
za% = Sheets("Befehle").Range("B24") 'erste und letzte Spalte, die auszuwerten sind
zo% = Sheets("Befehle").Range("B25")
For z% = za% To zo% 'ermittelt umständlich das Geschlecht des Pbn
lfd% = Sheets("PSSi-DatenT").Range("C2:C180").Cells(z%)
If Sheets("SCLDaten2").Range("E3:E180").Cells(lfd%).Value = "w" Then N$ = "PSSiNormenW"
If Sheets("SCLDaten2").Range("E3:E180").Cells(lfd%).Value = "m" Then N$ = "PSSiNormenM"
' N$ = "PSSiNormenM"
For sp% = 1 To 14
skala(sp%) = Sheets("PSSi-DatenT").Range("PssiRohwerte").Cells(z%, sp%)
Next sp%
For I% = 1 To 14
1 zähl% = zähl% + 1
'Y% = Range("NormenMänner").Cells(zähl%, 1)
x% = Sheets(N$).Cells(zähl% + 1, 1) 'der Summenwert aus der Normentabelle
If skala(I%) > x% Then GoTo 1
Sheets("Ergebnisse").Range("PssiTwerte").Cells(lfd%, I%) = Sheets(N$).Cells(zähl% + 1, I% + 1)
zähl% = 0
Next I%
Next z%
For z% = 1 To 14 'falls die Werte noch mal berechnet werden
skala(z%) = 0
Next z%
End Sub
Sub DiagrammSCL() 'malt das SCL-Diagramm für die ausgewählte lfd Nr
Nr1% = Sheets("Befehle").Range("B21") 'die lfd Nr
Nr2% = Sheets("Befehle").Range("B22")
Nr3% = Sheets("Befehle").Range("B23")
For I% = 1 To 10 'Skalenwerte in die Diagramm-Reihen einlesen
Sheets("Ergebnisse").Range("DiagrammReihen").Cells(I%, 1) = Sheets("Ergebnisse").Range("SCL_T_Werte").Cells(Nr1%, I%)
Sheets("Ergebnisse").Range("DiagrammReihen").Cells(I%, 2) = Sheets("Ergebnisse").Range("SCL_T_Werte").Cells(Nr2%, I%)
Sheets("Ergebnisse").Range("DiagrammReihen").Cells(I%, 3) = Sheets("Ergebnisse").Range("SCL_T_Werte").Cells(Nr3%, I%)
Next I%
'Sheets("Ergebnisse").Range("DiagrammReihen").Cells(11, 1) = 1
'Sheets("Ergebnisse").Range("DiagrammReihen").Cells(11, 2) = 3 'die Felder
'Sheets("Ergebnisse").Range("DiagrammReihen").Cells(11, 3) = 5
'die Legendenbeschriftung erzeugen, Sitzg nr x
Sheets("Ergebnisse").Range("DiagrammReihen").Cells(11, 1) = "Sitzung " + Str$(Sheets("Ergebnisse").Range("B3:I180").Cells(Nr1%, 7))
If Nr2% = 0 Then Sheets("Ergebnisse").Range("DiagrammReihen").Cells(11, 2) = " ": GoTo 2
Sheets("Ergebnisse").Range("DiagrammReihen").Cells(11, 2) = "Sitzung " + Str$(Sheets("Ergebnisse").Range("B3:I180").Cells(Nr2%, 7))
If Nr3% = 0 Then Sheets("Ergebnisse").Range("DiagrammReihen").Cells(11, 3) = " ": GoTo 2
Sheets("Ergebnisse").Range("DiagrammReihen").Cells(11, 3) = "Sitzung " + Str$(Sheets("Ergebnisse").Range("B3:I180").Cells(Nr3%, 7))
2 T1$ = Sheets("Ergebnisse").Range("B3:H180").Cells(Nr1%, 2) 'Namen und Vornamen zusammensetzen
T2$ = Sheets("Ergebnisse").Range("B3:H180").Cells(Nr1%, 1)
T3$ = T1$ + " " + T2$
Windows("SCL90.xls:1").Activate
ActiveSheet.ChartObjects("Diagramm 59").Activate
ActiveChart.ChartTitle.Select
'ActiveChart.ChartTitle.Text = "Heeehe"
With Selection.Characters(Start:=1, Length:=20).Font
.Name = "President"
.FontStyle = "Standard"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = True
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
'T$ = Sheets("Ergebnisse").Range("B3:H80").Cells(6, 1)
ActiveChart.ChartTitle.Text = "S y m p t o m - C h e c k für: " + Chr(10) + T3$ '"Husch spinnt ganz schönnn!!" 'Range("B26")
Sheets("Ergebnisse").Range("B35").Activate
'Sheets("Ergebnisse").ChartObjects("Diagramm 57").Activate
'ActiveSheet.ChartObjects("Diagramm 59").Activate
' ActiveChart.ChartTitle.Text = "Mistkram" '"Symptom-Check für: " + Str$(Sheets("Ergebnisse").Range("B3:H80").Cells(Nr1%, 1))
End Sub
Sub DiagrammPSSi()
Nr1% = Sheets("Befehle").Range("B21")
Nr2% = Sheets("Befehle").Range("B22")
For I% = 1 To 14
Sheets("Ergebnisse").Range("DiagrammReihen").Cells(I%, 4) = Sheets("Ergebnisse").Range("PssiTwerte").Cells(Nr1%, I%)
Sheets("Ergebnisse").Range("DiagrammReihen").Cells(I%, 5) = Sheets("Ergebnisse").Range("PssiTwerte").Cells(Nr2%, I%)
Next I%
Sheets("Ergebnisse").Range("DiagrammReihen").Cells(15, 4) = _
Sheets("Ergebnisse").Range("B3:I80").Cells(Nr1%, 1) + " " _
+ Str$(Sheets("Ergebnisse").Range("B3:I80").Cells(Nr1%, 7))
If Nr2% = 0 Then Sheets("Ergebnisse").Range("DiagrammReihen").Cells(15, 5) = 0: GoTo 2
Sheets("Ergebnisse").Range("DiagrammReihen").Cells(15, 5) = _
Sheets("Ergebnisse").Range("B3:I80").Cells(Nr2%, 1) + " " _
+ Str$(Sheets("Ergebnisse").Range("B3:I80").Cells(Nr2%, 7))
'"Sitzung " + Str$(Sheets("Ergebnisse").Range("B3:I80").Cells(Nr2%, 7))
' Sheets("Ergebnisse").Range("DiagrammReihen").Cells(11, 2) = "Sitzung " + Str$(Sheets("Ergebnisse").Range("B3:I80").Cells(Nr2%, 7))
2 T1$ = Sheets("Ergebnisse").Range("B3:I80").Cells(Nr1%, 2)
T2$ = Sheets("Ergebnisse").Range("B3:I80").Cells(Nr1%, 1)
T3$ = T1$ + " " + T2$
Windows("SCL90.xls:1").Activate
ActiveSheet.ChartObjects("Diagramm 57").Activate
ActiveChart.ChartTitle.Select
'ActiveChart.ChartTitle.Text = "Heeehe"
With Selection.Characters(Start:=1, Length:=20).Font
.Name = "President"
.FontStyle = "Standard"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = True
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
ActiveChart.ChartTitle.Text = "P e r s ö n l i c h k e i t s - P r o f i l für: " + Chr(10) + T3$ '"Husch spinnt ganz schönnn!!" 'Range("B26")
Sheets("Ergebnisse").Range("B35").Activate
End Sub
Sub ItemsSkalenZeigen()
Nr% = Sheets("PSSi-Ergebn").Range("B74") 'schreibt den Skalennamen in ein Text feld
T1$ = Sheets("PSSi-Ergebn").Range("SkalenNamen").Cells(Nr%, 1)
' " & Chr(10) & "" & Chr(10) & "" & Chr(10) & ""
'Sheets("PSSi-Ergebn").Range("PssiTwerte").Cells(z%, sp%)
For z% = 1 To 140
If Sheets("Pssi-Polung").Range("PssiPolung").Cells(z%, 2) = Nr% Then
T2$ = T2$ + Sheets("Pssi-Polung").Range("PssiPolung").Cells(z%, 4) + Chr(10)
End If
Next z%
'ActiveSheet.Shapes("Text Box 39").Select
'With Selection.Characters(Start:=1, Length:=10).Font
' .Name = "Frankenstein"
' .FontStyle = "Standard"
' .Size = 14
'End With
ActiveSheet.TextBox1.Text = T2$
ActiveSheet.TextBox3.Text = T1$
Sheets("PSSi-Ergebn").Range("B74").Value = Nr% + 1
End Sub
Sub Transformation()
'wandelt die erste SCLDAtentab um in SCL2
For sp% = 1 To 27
For z% = 1 To 90
Sheets("SCLDaten2").Range("SCLRohDaten").Cells(sp%, z%) = Range("RohDaten").Cells(z% + 10, sp%)
Next z%
Next sp%
For sp% = 1 To 90 'kopiert die Skalenzuordnung
Sheets("SCLDaten2").Range("I1:CT1").Cells(1, sp%) = Range("ZuSkala").Cells(sp%, 1)
Next sp%
End Sub
Sub PssiDiagrammHolen() 'bewegt das SCLDiagramm nach links und rechts
'Worksheets("Ergebnisse").Activate
Windows("SCL90.xls:1").Activate
ActiveSheet.ChartObjects("Diagramm 57").Activate
If ActiveSheet.Shapes("Diagramm 57").Left > 500 Then
ActiveSheet.Shapes("Diagramm 57").Left = 30
Windows("SCL90.xls:2").Activate
Sheets("Befehle").Range("B35").Activate
Exit Sub
End If
If ActiveSheet.Shapes("Diagramm 57").Left < 500 Then
ActiveSheet.Shapes("Diagramm 57").Left = 1000
End If
Windows("SCL90.xls:2").Activate
Sheets("Befehle").Range("B20").Activate
End Sub
Sub SCLDiagrammHolen() 'bewegt das SCLDiagramm nach links und rechts
'Worksheets("Ergebnisse").Activate
Windows("SCL90.xls:1").Activate
ActiveSheet.ChartObjects("Diagramm 59").Activate
If ActiveSheet.Shapes("Diagramm 59").Left > 500 Then
ActiveSheet.Shapes("Diagramm 59").Left = 30
Windows("SCL90.xls:2").Activate
Sheets("Befehle").Range("B35").Activate
Exit Sub
End If
If ActiveSheet.Shapes("Diagramm 59").Left < 500 Then
ActiveSheet.Shapes("Diagramm 59").Left = 1000
End If
Windows("SCL90.xls:2").Activate
Sheets("Befehle").Range("B20").Activate
End Sub
|