Sub test()

Dim Strtpt_val As Integer
Dim strtpt_x As Integer
Dim strtpt_y As Integer
Dim grid_x1 As Integer
Dim grid_x2 As Integer
Dim x_val As Integer
Dim x_val2 As Integer
Dim x_anz As Integer
Dim x_poskor As Integer
Dim x_end As Integer

Dim y_val As Integer
Dim y_val2 As Integer
Dim y_anz As Integer
Dim y_poskor As Integer
Dim y_end As Integer

Strtpt_val = ActiveCell.Value
strtpt_x = ActiveCell.Column
strtpt_y = ActiveCell.Row
'MsgBox (Strtpt_val)
'MsgBox (strtpt_x)
'MsgBox (strtpt_y)
'--------------- X- ---------
grid_x1 = strtpt_x - (Strtpt_val * 2 - 2)
'MsgBox (grid_x1)
x = 0
x_val = Strtpt_val - 1
x_anz = 0
For x_end = 1 To 1
    Do
        Do
            x_poskor = 1 + x + (2 * x_anz)
            Cells(strtpt_y, strtpt_x - x_poskor) = x_val
            x = x + 1
            If x = 2 Then
                x_val = x_val - 1
                x_anz = x_anz + 1
                x = 0
                Exit Do
            End If
        Loop Until x_val = 0
        If x_val = 0 Then
            Exit Do
            x_end = 1
        End If
        'Exit Do
    Loop Until x_val = 0
Next
'---------------- X- -> X+ ---------
grid_x2 = strtpt_x + (Strtpt_val * 2 - 2)
'MsgBox (grid_x1)
x = 0
x_val = Strtpt_val - 1
x_anz = 0
For x_end = 1 To 1
    Do
        Do
            x_poskor = 1 + x + (2 * x_anz)
            Cells(strtpt_y, strtpt_x + x_poskor) = x_val
            x = x + 1
            If x = 2 Then
                x_val = x_val - 1
                x_anz = x_anz + 1
                x = 0
                Exit Do
            End If
        Loop Until x_val = 0
        If x_val = 0 Then
            Exit Do
            x_end = 1
        End If
        'Exit Do
    Loop Until x_val = 0
Next

'############################################
Dim i_val As Integer
Dim i_x As Integer

Cells(strtpt_y, grid_x1).Activate
i_val = Cells(strtpt_y, grid_x1).Value
i_x = grid_x1

Do
    '--------------- Y- ---------
    grid_y1 = strtpt_y - (i * 2 - 2)
    y = 0
    y_val = i_val - 1
    y_anz = 0
    For y_end = 1 To 1
        Do
            Do
                y_poskor = 1 + y + (2 * y_anz)
                Cells(strtpt_y - y_poskor, i_x) = y_val
                y = y + 1
                If y = 2 Then
                    y_val = y_val - 1
                    y_anz = y_anz + 1
                    y = 0
                    Exit Do
                End If
            Loop Until y_val = 0
            If y_val = 0 Then
                Exit Do
                y_end = 1
            End If
        Loop Until y_val = 0
    Next
    '---------------- y- -> y+ ---------
    grid_y2 = strtpt_y + (i * 2 - 2)
    y = 0
    y_val = i_val ' - 1
    y_anz = 0
    For y_end = 1 To 1
        Do
            Do
                y_poskor = 1 + y + (2 * y_anz)
                Cells(strtpt_y + y_poskor, i_x) = y_val
                y = y + 1
                If y = 2 Then
                    y_val = y_val - 1
                    y_anz = y_anz + 1
                    y = 0
                    Exit Do
                End If
            Loop Until y_val = 0
            If y_val = 0 Then
                Exit Do
                y_end = 1
            End If
        Loop Until y_val = 0
    Next
  
If i_val = 0 Then
Exit Do
End If
i_x = i_x + 1
i_val = Cells(strtpt_y, i_x).Value
Loop Until i_val = 0
End Sub