title image


Smiley Re: VBA: Großes Problem mit einer Schleifenprogrammierung?
Vielleicht mit Makro und dieses Manuell starten. Das kann allerdings bei der Anzahl Deiner Werte ziemlich lange dauern...







      

Sub DataCompare()



    Dim bExitSub As Boolean

    Dim iDataRow, iDataColumn, iResultColumn, iDataStartRow As Integer

    Dim MaxPercent, MinPercent

    Dim DataValue, MaxDataValue, MinDataValue

    

    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

        

        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: