Sub PTableRefresh()
'Update changes in the coordinate system

    Dim Pos1 As Integer, Pos2 As Integer, Pos3 As Integer, Pos4 As Integer, Pos5 As Integer, Pos6 As Integer, Pos7 As Integer, Pos8 As Integer
    Dim EntireRefRow As Integer, EntireFinRow As Integer, ObjRefRow As Integer, ObjFinRow As Integer
    
    Pos1 = InStr(ActiveSheet.Shapes(Application.Caller).name, "(")
    Pos2 = InStr(ActiveSheet.Shapes(Application.Caller).name, ")")
    Pos3 = InStr(ActiveSheet.Shapes(Application.Caller).name, "[")
    Pos4 = InStr(Pos4 + 1, ActiveSheet.Shapes(Application.Caller).name, "]")
    Pos5 = InStr(Pos4 + 1, ActiveSheet.Shapes(Application.Caller).name, "(")
    Pos6 = InStr(Pos4 + 1, ActiveSheet.Shapes(Application.Caller).name, ")")
    Pos7 = InStr(Pos4 + 1, ActiveSheet.Shapes(Application.Caller).name, "[")
    Pos8 = InStr(Pos4 + 1, ActiveSheet.Shapes(Application.Caller).name, "]")
    On Error Resume Next
    EntireRefRow = Mid(ActiveSheet.Shapes(Application.Caller).name, Pos1 + 1, Pos2 - Pos1 - 1)
    EntireFinRow = Mid(ActiveSheet.Shapes(Application.Caller).name, Pos3 + 1, Pos4 - Pos3 - 1)
    ObjRefRow = Mid(ActiveSheet.Shapes(Application.Caller).name, Pos5 + 1, Pos6 - Pos5 - 1)
    ObjFinRow = Mid(ActiveSheet.Shapes(Application.Caller).name, Pos7 + 1, Pos8 - Pos7 - 1)
        
    Range("B2").Value = Abs(Cells(EntireRefRow + 2, 5).Value - Cells(EntireRefRow + 1, 7).Value)
    If Cells(EntireRefRow + 2, 5).Value < Cells(EntireRefRow + 1, 7).Value Then
        If Left(ActiveSheet.Shapes(Application.Caller).name, 7) = "DelButt" Then
            ActiveSheet.Shapes(Application.Caller).name = "AddButt(" & EntireRefRow & ")[" & EntireFinRow & "](" & ObjRefRow & ")[" & ObjFinRow & "]" & Right(ActiveSheet.Shapes(Application.Caller).name, 3)
            Exit Sub
        End If
    ElseIf Cells(EntireRefRow + 2, 5).Value > Cells(EntireRefRow + 1, 7).Value Then
        If Left(ActiveSheet.Shapes(Application.Caller).name, 7) = "AddButt" Then
            ActiveSheet.Shapes(Application.Caller).name = "DelButt(" & EntireRefRow & ")[" & EntireFinRow & "](" & ObjRefRow & ")[" & ObjFinRow & "]" & Right(ActiveSheet.Shapes(Application.Caller).name, 3)
            Exit Sub
        End If
    End If
sig:
    Call PTElectronicConfig(EntireRefRow + 7) ' Get electronic configurations
    Call AddObject ' Add or remove atoms
    Call UpdateShapeNamesPT(EntireRefRow, ObjRefRow, ObjFinRow - ObjRefRow + 1)  'Update reference cells for atomos
End Sub
Sub PTableDuplicateAtom() 'modified 25 nov 2025

'Segment PTableDuplicateAtom-01. Define variables
    Range("AB19").Value = 1
    Dim Pos1 As Integer, Pos2 As Integer, Pos3 As Integer, Pos4 As Integer, Pos5 As Integer, Pos6 As Integer, Pos7 As Integer, Pos8 As Integer
    Dim EntireRefRow As Integer, EntireFinRow As Integer, ObjRefRow As Integer, ObjFinRow As Integer
    Dim ButtonCol As Integer
    ButtonCol = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Column

    Pos1 = InStr(ActiveSheet.Shapes(Application.Caller).name, "(")
    Pos2 = InStr(ActiveSheet.Shapes(Application.Caller).name, ")")
    Pos3 = InStr(ActiveSheet.Shapes(Application.Caller).name, "[")
    Pos4 = InStr(Pos4 + 1, ActiveSheet.Shapes(Application.Caller).name, "]")
    Pos5 = InStr(Pos4 + 1, ActiveSheet.Shapes(Application.Caller).name, "(")
    Pos6 = InStr(Pos4 + 1, ActiveSheet.Shapes(Application.Caller).name, ")")
    Pos7 = InStr(Pos4 + 1, ActiveSheet.Shapes(Application.Caller).name, "[")
    Pos8 = InStr(Pos4 + 1, ActiveSheet.Shapes(Application.Caller).name, "]")
    On Error Resume Next
    EntireRefRow = Mid(ActiveSheet.Shapes(Application.Caller).name, Pos1 + 1, Pos2 - Pos1 - 1)
    EntireFinRow = Mid(ActiveSheet.Shapes(Application.Caller).name, Pos3 + 1, Pos4 - Pos3 - 1)
    ObjRefRow = Mid(ActiveSheet.Shapes(Application.Caller).name, Pos5 + 1, Pos6 - Pos5 - 1)
    ObjFinRow = Mid(ActiveSheet.Shapes(Application.Caller).name, Pos7 + 1, Pos8 - Pos7 - 1)
    
    If Cells(EntireRefRow, ButtonCol + 2).Value <> "" Then
        'Molecule mode - cell contains MoleculeFinRow
        EntireFinRow = Cells(EntireRefRow, ButtonCol + 2).Value
    End If

'Segment PTableDuplicateAtom-02. Prepare cell values to duplicate and call the function to duplicate
    Range("B2").Value = "ENTIRE"
    Range("C3").Value = EntireFinRow
    Range("B3").FormulaR1C1 = "=IF(R[-1]C=""ENTIRE""," & EntireRefRow & "," & EntireRefRow + ObjFinRow - ObjRefRow + 1 & ")"

    Call AddObject

    Range("B2").Value = ""
    Range("C3").Value = ObjFinRow
    Range("B3").FormulaR1C1 = "=IF(R[-1]C=""ENTIRE""," & EntireRefRow & "," & ObjRefRow & ")"

'Segment PTableDuplicateAtom-03. Rename button and combobox names
    Call UpdateShapeNamesPT(EntireRefRow, ObjRefRow, ObjFinRow - ObjRefRow + 1)

End Sub

Sub UpdateShapeNamesPT(ByVal EntireRefRow As Integer, ObjIniRow As Integer, RowQty As Integer)
'EntireRefRow - Row where the ENTIRE object begins (atom), ObjIniRow - Row where the small object begins (electron), RowQty -number of rows of the small object (of one electron).

    Dim shp As Shape
    Dim RefValue As String
    Dim RightPart As String
    Dim EntireFinRow As Integer
    EntireRefRow = 15
    RefValue = Range("D30").Value ' the value of reference, E_0, V_0, etc. between two atoms

    For Each shp In ActiveSheet.Shapes
        If shp.Type = msoFormControl Then

            If shp.FormControlType = xlDropDown Then
                If Left(shp.name, 8) = "Elements" Then
                    shp.name = "Elements" & shp.TopLeftCell.Row
                    shp.Select
                    With Selection
                        .LinkedCell = Cells(shp.TopLeftCell.Row + 1, 7).Address
                    End With
                End If
            End If
            If shp.FormControlType = xlSpinner Then
                If Left(shp.name, 8) = "Spinner1" Then
                    shp.name = "Spinner1" & shp.TopLeftCell.Row
                    shp.Select
                    With Selection
                        .LinkedCell = Cells(shp.TopLeftCell.Row + 1, 4).Address
                    End With
                End If
                If Left(shp.name, 8) = "Spinner2" Then
                    shp.name = "Spinner2" & shp.TopLeftCell.Row
                    shp.Select
                    With Selection
                        .LinkedCell = Cells(shp.TopLeftCell.Row + 1, 5).Address
                    End With
                End If
            End If
            ActiveSheet.Shapes("Conf_" & 24).Select

            If shp.FormControlType = xlButtonControl Then 'Update all the names of the buttons
            RightPart = Mid(shp.name, InStr(1, shp.name, "]", 0) + 1)
                If Right(shp.name, 2) = "PT" Then
                    i = 1
                    Do While Cells(shp.TopLeftCell.Row + EntireRefRow + i * RowQty, 4).Value <> ""

                        If Cells(shp.TopLeftCell.Row + EntireRefRow + i * RowQty, 4).Value = RefValue Then
                            EntireFinRow = Cells(shp.TopLeftCell.Row + i * RowQty, 4).Row - 1
                            GoTo GotFinRow
                        ElseIf Cells(shp.TopLeftCell.Row + ObjIniRow + i * RowQty, 4).Value = "" Then
                            EntireFinRow = Cells(shp.TopLeftCell.Row + (i + 1) * RowQty, 4).Row - 1
                            GoTo GotFinRow
                        End If
                        i = i + 1
                    Loop
GotFinRow:
                    shp.name = Left(shp.name, 8) & shp.TopLeftCell.Row & ")[" & EntireFinRow & "]" & RightPart
                End If
            End If

        End If
    Next shp
End Sub
Sub PTCleanTable()
        Dim r As Range
        Dim last As Single
        Set r = ActiveSheet.Range("A6")
        ActiveSheet.Range("T8").Value = 1
        'Clean table
        If Cells(r.Row + 7, r.Column + 1).Value > 0 And Cells(r.Row + 8, r.Column + 1).Value > 0 Then 'verify if data exists
            If Cells(Cells(r.Row + 7, r.Column + 1).Value, Cells(r.Row + 8, r.Column + 1).Value).Value <> "" Then
                i = 1
                Do While Cells(Cells(r.Row + 7, r.Column + 1).Value + i, Cells(r.Row + 8, r.Column + 1).Value).Value <> ""
                    i = i + 1
                Loop
            End If
            Range(Cells(Cells(r.Row + 7, r.Column + 1).Value - 4, Cells(r.Row + 8, r.Column + 1).Value), Cells(Cells(r.Row + 7, r.Column + 1).Value + i, Cells(r.Row + 8, r.Column + 1).Value + 9)).Select
            Selection.ClearContents
            Range("H10").Select
        End If
        'End of clean table
        ActiveSheet.Range("T8").Value = 2
        Range("B13").FormulaR1C1 = "=IF(R[-5]C[18]=1,50,0)"
        Range("B14").FormulaR1C1 = "=IF(R[-6]C[18]=1,10,0)"
End Sub
Sub PTRotateElectrons()

' Set field view to a point in space
    Range("AB19").Value = 1
    
' Set the dynamic angles and rotate
    Range("W23").FormulaR1C1 = "=0+R[-18]C[-14]"
    Range("W24").FormulaR1C1 = "=0+R[-19]C[-14]*2"
    Range("Y23").FormulaR1C1 = "=360+R[-18]C[-16]"
    Range("Y24").FormulaR1C1 = "=180+R[-19]C[-16]*2"
    
    Call rotate_n
    
' Set the default values and default view
    Range("W23").FormulaR1C1 = 90
    Range("W24").FormulaR1C1 = 0
    Range("Y23").FormulaR1C1 = 90
    Range("Y24").FormulaR1C1 = 360
    
    Call Reset
    
End Sub

Sub PTElectronicConfig(ByVal ConfRow As Integer)
'Electronic configuration output

'Segment PTElectronicConfig-01. Define variables
    Dim Z As Integer
    Dim config As String
    Dim electronesRestantes As Integer
    Dim n As Integer, l As Integer
    Dim orbital As Variant
    Dim e As Integer, max_e As Integer
    Dim configPorNivel(1 To 7) As String ' Array to store config by level (n=1 a 7)
    
'Segment PTElectronicConfig-02. Define atomic number
    On Error Resume Next
    Z = Range("G" & ConfRow - 6).Value
    On Error GoTo 0
    
'Segment PTElectronicConfig-03. Validate Z
    If Z < 1 Or Z > 118 Then
        MsgBox "Atomic number must be between 1 and 118", vbExclamation
        Exit Sub
    End If
    
    electronesRestantes = Z
    
'Segment PTElectronicConfig-04. Initialize array
    For n = 1 To 7
        configPorNivel(n) = ""
    Next n
    
'Segment PTElectronicConfig-05. Filling according to Madelung's rule (n+l)
    Dim ordenLlenado() As Variant
    ordenLlenado = Array("1s", "2s", "2p", "3s", "3p", "4s", "3d", "4p", "5s", "4d", "5p", _
                         "6s", "4f", "5d", "6p", "7s", "5f", "6d", "7p")
    
    'Handling known exceptions
    If Z = 24 Then ' Cromo
        configPorNivel(1) = "1s2"
        configPorNivel(2) = "2s2 2p6"
        configPorNivel(3) = "3s2 3p6 3d5"
        configPorNivel(4) = "4s1"
    ElseIf Z = 29 Then ' Cobre
        configPorNivel(1) = "1s2"
        configPorNivel(2) = "2s2 2p6"
        configPorNivel(3) = "3s2 3p6 3d10"
        configPorNivel(4) = "4s1"
    Else
        ' Normal filling
        For Each orbital In ordenLlenado
            If electronesRestantes <= 0 Then Exit For
            
            n = CInt(Left(orbital, 1))
            l = InStr("spdf", Right(orbital, 1)) - 1
            
            Select Case l
                Case 0: max_e = 2  ' s
                Case 1: max_e = 6  ' p
                Case 2: max_e = 10 ' d
                Case 3: max_e = 14 ' f
            End Select
            
            e = Application.Min(max_e, electronesRestantes)
            If e > 0 Then
                configPorNivel(n) = configPorNivel(n) & orbital & e & " "
                electronesRestantes = electronesRestantes - e
            End If
        Next orbital
    End If
    
'Segment PTElectronicConfig-06. show results (n=1 a n=7)
    For n = 1 To 7
        If configPorNivel(n) <> "" Then
            Range("H" & (ConfRow + n)).Value = Trim(configPorNivel(n))
        Else
            Range("H" & (ConfRow + n)).Value = "" ' Limpiar celda si no hay electrones
        End If
    Next n
    
End Sub