Thema: Werte um einen vorgegebenen Faktor erhöhen und verschieden runden

StandardModule: basMain

Sub ErhoehenUndFormatieren()
   Dim rng As Range
   Dim dValue As Double
   Dim iCounter As Integer, iRow As Integer
   Application.ScreenUpdating = False
   iRow = Cells(Rows.Count, 1).End(xlUp).Row
   Range("C1").Copy
   Range("A1:A" & iRow).PasteSpecial _
      Paste:=xlValues, _
      Operation:=xlMultiply, _
      SkipBlanks:=False, _
      Transpose:=False
   For iCounter = 1 To iRow
      dValue = Cells(iRow, 1).Value
      Select Case dValue
         Case Is <= 20
            Cells(iRow, 1) = WorksheetFunction.Round(dValue, 2)
         Case Is <= 50
            Cells(iRow, 1) = WorksheetFunction.Round(dValue / 5, 2) * 5
         Case Is <= 100
            Cells(iRow, 1) = WorksheetFunction.Round(dValue / 10, 2) * 10
         Case Is <= 500
            Cells(iRow, 1) = WorksheetFunction.Round(dValue / 50, 2) * 50
         Case Else
            Cells(iRow, 1) = WorksheetFunction.Round(dValue / 100, 2) * 100
      End Select
   Next iCounter
   Application.CutCopyMode = False
   Application.ScreenUpdating = True
End Sub

Beiträge aus dem Excel-Forum zu den Themen Allgemein und Berechnen