title image


Smiley Re: ... noch eine Kleinigkeit?
Vielleicht so ?







      

Sub DataCompare()



    Dim bExitSub As Boolean

    Dim iDataRow, iDataColumn, iResultColumn, iDataStartRow As Integer

    Dim MaxPercent, MinPercent, DataValue, MaxDataValue, MinDataValue, LastDataValue

    

    iDataStartRow = 10

    iDataRow = iDataStartRow: iDataColumn = 2: iResultColumn = 3

    MaxPercent = Cells(1, 1).Value: MinPercent = Cells(2, 1).Value

    MaxPercent = 100 + MaxPercent: MinPercent = 100 - MinPercent

    bExitSub = False

    While Not bExitSub

        DataValue = Cells(iDataRow, iDataColumn).Value

        If DataValue Then

            If iDataRow = iDataStartRow Then

                MaxDataValue = PercentValue(DataValue, MaxPercent)

                MinDataValue = PercentValue(DataValue, MinPercent)

                Cells(iDataRow, iResultColumn).Value = ""

                

            Else

                If DataValue >= MaxDataValue Then

                    Cells(iDataRow, iResultColumn).Value = ">=" & Cells(1, 1).Value & "% (Grenzwert " & MaxDataValue & ")"

                    MaxDataValue = PercentValue(DataValue, MaxPercent)

                    MinDataValue = PercentValue(DataValue, MinPercent)

                

                ElseIf DataValue <= MinDataValue Then

                    Cells(iDataRow, iResultColumn).Value = "<=" & Cells(2, 1).Value & "% (Grenzwert " & MinDataValue & ")"

                    MaxDataValue = PercentValue(DataValue, MaxPercent)

                    MinDataValue = PercentValue(DataValue, MinPercent)

                    

                Else

                    Cells(iDataRow, iResultColumn).Value = ""

                

                End If

            

            End If

                

            If LastDataValue < DataValue Then

                'positiver Verlauf

                MinDataValue = PercentValue(DataValue, MinPercent)

        

            ElseIf LastDataValue > DataValue Then

                'negativer Verlauf

                MaxDataValue = PercentValue(DataValue, MaxPercent)



            End If

            

            'die folgenden 2 Zeilen sind nur zur Darstellung der aktuellen Grenzwerte

            Cells(iDataRow, iResultColumn + 1).Value = MinDataValue

            Cells(iDataRow, iResultColumn + 2).Value = MaxDataValue

            'Ende Darstellung der Grenzwerte

            

            LastDataValue = DataValue

        

        Else

            bExitSub = True

        

        End If

        iDataRow = iDataRow + 1

    

    Wend

    

End Sub



Function PercentValue(Value, Percent)



    PercentValue = Value * Percent / 100

    

End Function 





Code eingefügt mit Syntaxhighlighter 3.0






Wer weiß schon, was er nicht weiß...(ich zähle mich auch dazu) Holger

geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: