Cross sum from a number but cross sum should total to one digit

Question

I want to get cross sum of numbers rounding to one digit.

For example 789 = 24 but I want to get 6 from the first time.

Sub quersumme()

Dim a As Integer
Dim ln As Integer
Dim mystring As Integer


On Error Resume Next
mystring = Cells(1, 1).Value

a = 0
ln = Len(mystring)

For i = 1 To ln
a = a + Mid(mystring, i, 1)


Next i

Cells(1, 2) = a

End Sub

Answer 1

Try this:

Option Explicit

Sub Quersumme_OneDigit()

    Dim res As Long
    res = Cells(1, 1).Value
    
    Do
        res = Quersumme(res)
    Loop Until res < 10

    Cells(1, 2) = res

End Sub

Function Quersumme(ByVal Zahl As Double) As Double
    Dim i  As Long
    Dim Summe As Double

    For i = 1 To Len(CStr(Zahl))
        Summe = Summe + Mid(CStr(Zahl), i, 1)
    Next
    Quersumme = Summe
End Function