Private Function GetDic() As Object
    Dim col As New Collection
    '-----------------------------------------------------------------------
    col.Add "A: GCA, GCC, GCG, GCT"
    col.Add "C: TGC, TGT"
    col.Add "D: GAC, GAT"
    col.Add "E: GAA, GAG"
    col.Add "F: TTC, TTT"
    col.Add "G: GGA, GGC, GGG, GGT"
    col.Add "H: CAC, CAT"
    col.Add "I: ATA, ATC, ATT"
    col.Add "K: AAA, AAG"
    col.Add "L: CTA, CTC, CTG, CTT, TTA, TTG"
    col.Add "M: ATG"
    col.Add "N: AAC, AAT"
    col.Add "P: CCA, CCC, CCG, CCT"
    col.Add "Q: CAA, CAG"
    col.Add "R: AGA, AGG, CGA, CGC, CGG, CGT"
    col.Add "S: AGC, AGT, TCA, TCC, TCG, TCT"
    col.Add "T: ACA, ACC, ACG, ACT"
    col.Add "V: GTA, GTC, GTG, GTT"
    col.Add "W: TGG"
    col.Add "Y: TAC, TAT"
    col.Add "STOP: TAA, TAG, TGA"
    '-----------------------------------------------------------------------
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim ss As String
    Dim aa As Variant
    Dim bb As Variant
    Dim arr As Variant
    Dim brr As Variant
    For Each aa In col
        arr = Split(aa, ":")
        brr = Split(arr(1), ",")
        For Each bb In brr
            ss = Trim(bb)
            dic(ss) = arr(0)
        Next
    Next
    
    Set GetDic = dic
End Function

Function Альтернативная_трасляция(ТЕКСТ As String, Optional StartCodon As String, Optional EntryStartCodon As Long = 1) As String
    Dim ii As Integer
    Dim Rez As String
    Dim ss As String
    Dim sMid As String
    Dim flag As Boolean
    Dim curEntryStartCodon As Long
    If StartCodon = "" Then flag = True
    
    Dim dic As Object
    Set dic = GetDic()
    
    For ii = 1 To Len(ТЕКСТ) Step 3
        sMid = Mid(ТЕКСТ, ii, 3)
        If flag = False Then
            If sMid = StartCodon Then
                curEntryStartCodon = curEntryStartCodon + 1
                If curEntryStartCodon = EntryStartCodon Then
                    flag = True
                End If
            End If
        End If
        If flag Then
            If dic.Exists(sMid) Then
                ss = dic(sMid)
                If ss = "STOP" Then
                    Exit For
                End If
            End If
            Rez = Rez & ss
        End If
    Next ii
    Альтернативная_трасляция = Rez
End Function

Private Function GetDic() As Object
    Dim col As New Collection
    '-----------------------------------------------------------------------
    col.Add "A: GCA, GCC, GCG, GCT"
    col.Add "C: TGC, TGT"
    col.Add "D: GAC, GAT"
    col.Add "E: GAA, GAG"
    col.Add "F: TTC, TTT"
    col.Add "G: GGA, GGC, GGG, GGT"
    col.Add "H: CAC, CAT"
    col.Add "I: ATA, ATC, ATT"
    col.Add "K: AAA, AAG"
    col.Add "L: CTA, CTC, CTG, CTT, TTA, TTG"
    col.Add "M: ATG"
    col.Add "N: AAC, AAT"
    col.Add "P: CCA, CCC, CCG, CCT"
    col.Add "Q: CAA, CAG"
    col.Add "R: AGA, AGG, CGA, CGC, CGG, CGT"
    col.Add "S: AGC, AGT, TCA, TCC, TCG, TCT"
    col.Add "T: ACA, ACC, ACG, ACT"
    col.Add "V: GTA, GTC, GTG, GTT"
    col.Add "W: TGG"
    col.Add "Y: TAC, TAT"
    col.Add "STOP: TAA, TAG, TGA"
    '-----------------------------------------------------------------------
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim ss As String
    Dim aa As Variant
    Dim bb As Variant
    Dim arr As Variant
    Dim brr As Variant
    For Each aa In col
        arr = Split(aa, ":")
        brr = Split(arr(1), ",")
        For Each bb In brr
            ss = Trim(bb)
            dic(ss) = arr(0)
        Next
    Next
    
    Set GetDic = dic
End Function

Function КОДДОНСМЕЩ(ByVal ТЕКСТ As String, Optional StartCodon As String, Optional EntryStartCodon As Long = 1) As String
    Dim curEntryStartCodon As Long
    Dim sMid As String
    Dim ii As Long
    For ii = 1 To Len(ТЕКСТ) - 2
        sMid = Mid(ТЕКСТ, ii, 3)
        If sMid = StartCodon Then
            curEntryStartCodon = curEntryStartCodon + 1
            If curEntryStartCodon = EntryStartCodon Then
                ТЕКСТ = Mid(ТЕКСТ, ii, Len(ТЕКСТ))
                Exit For
            End If
        End If
    Next
    КОДДОНСМЕЩ = ТЕКСТ
End Function

Function ТРАНСЛЯЦИЯ(ByVal ТЕКСТ As String) As String
    Dim ii As Integer
    Dim Rez As String
    Dim ss As String
    Dim sMid As String
    Dim curEntryStartCodon As Long
    
    Dim dic As Object
    Set dic = GetDic()
    
    For ii = 1 To Len(ТЕКСТ) Step 3
        sMid = Mid(ТЕКСТ, ii, 3)
        ss = ""
        If dic.Exists(sMid) Then
            ss = dic(sMid)
            If ss = "STOP" Then
                Exit For
            End If
        End If
        Rez = Rez & ss
    Next ii
    
    ТРАНСЛЯЦИЯ = Rez
End Function

Function Альтернативная_трасляция(ByVal ТЕКСТ As String, Optional StartCodon As String, Optional EntryStartCodon As Long = 1) As String
    Dim ii As Integer
    Dim Rez As String
    Dim ss As String
    Dim sMid As String
    Dim curEntryStartCodon As Long
    
    For ii = 1 To Len(ТЕКСТ) - 2
        sMid = Mid(ТЕКСТ, ii, 3)
        If sMid = StartCodon Then
            curEntryStartCodon = curEntryStartCodon + 1
            If curEntryStartCodon = EntryStartCodon Then
                ТЕКСТ = Mid(ТЕКСТ, ii, Len(ТЕКСТ))
                Exit For
            End If
        End If
    Next
    
    For ii = 1 To Len(ТЕКСТ) Step 3
        sMid = Mid(ТЕКСТ, ii, 3)
        ss = ""
        Select Case sMid
        Case "GCA", "GCC", "GCG", "GCT": ss = "A"
        Case "TGC", "TGT": ss = "C"
        Case "GAC", "GAT": ss = "D"
        Case "GAA", "GAG": ss = "E"
        Case "TTC", "TTT": ss = "F"
        Case "GGA", "GGC", "GGG", "GGT": ss = "G"
        Case "CAC", "CAT": ss = "H"
        Case "ATA", "ATC", "ATT": ss = "I"
        Case "AAA", "AAG": ss = "K"
        Case "CTA", "CTC", "CTG", "CTT", "TTA", "TTG": ss = "L"
        Case "ATG": ss = "M"
        Case "AAC", "AAT": ss = "N"
        Case "CCA", "CCC", "CCG", "CCT": ss = "P"
        Case "CAA", "CAG": ss = "Q"
        Case "AGA", "AGG", "CGA", "CGC", "CGG", "CGT": ss = "R"
        Case "AGC", "AGT", "TCA", "TCC", "TCG", "TCT": ss = "S"
        Case "ACA", "ACC", "ACG", "ACT": ss = "T"
        Case "GTA", "GTC", "GTG", "GTT": ss = "V"
        Case "TGG": ss = "W"
        Case "TAC", "TAT": ss = "Y"
        Case "TAA", "TAG", "TGA": ss = "STOP"
        End Select
        
        If ss = "STOP" Then
            Exit For
        End If
        Rez = Rez & ss
    Next ii
    
    Альтернативная_трасляция = Rez
End Function

Function Translation3(Txt As String, Optional FrameNum As Long = 1, Optional StartCodon As String, Optional EntryStartCodon As Long = 1) As String
' ZVI:2024-06-10 https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&TID=165512
' Convert Txt nucleotide sequence into an amino acid translation
'
' Function arguments
' Txt                     - Nucleotide sequence. Spases can be used as they are ignored
' [FrameNum] = [1],2,3    - Frame number
' [StartCodon]            - Codon to find
' [EntryStartCodon] = [1] - Codons count to start from
  
  Dim a(), i As Long, j As Long, k As Long, sTxt As String, sCodon As String
  sTxt = Mid$(Replace(Txt, " ", vbNullString), FrameNum)
  k = Len(sTxt)
  If k = 0 Then Exit Function
  If StartCodon <> vbNullString Then
    For i = 1 To EntryStartCodon
      Do
        j = InStr(j + 1, sTxt, StartCodon, vbBinaryCompare)
      Loop While j <> 0 And ((j - 1) Mod 3) <> 0
      If j = 0 Then Exit Function
    Next
  End If
  If j = 0 Then j = 1
  
  ReDim a(j To k)
  For i = j To k - 2 Step 3
    sCodon = Mid$(sTxt, i, 3)
    Select Case sCodon
      Case "GCA", "GCC", "GCG", "GCT": a(i) = "A"
      Case "TGC", "TGT": a(i) = "C"
      Case "GAC", "GAT": a(i) = "D"
      Case "GAA", "GAG": a(i) = "E"
      Case "TTC", "TTT": a(i) = "F"
      Case "GGA", "GGC", "GGG", "GGT": a(i) = "G"
      Case "CAC", "CAT": a(i) = "H"
      Case "ATA", "ATC", "ATT": a(i) = "I"
      Case "AAA", "AAG": a(i) = "K"
      Case "CTA", "CTC", "CTG", "CTT", "TTA", "TTG": a(i) = "L"
      Case "ATG": a(i) = "M"
      Case "AAC", "AAT": a(i) = "N"
      Case "CCA", "CCC", "CCG", "CCT": a(i) = "P"
      Case "CAA", "CAG": a(i) = "Q"
      Case "AGA", "AGG", "CGA", "CGC", "CGG", "CGT": a(i) = "R"
      Case "AGC", "AGT", "TCA", "TCC", "TCG", "TCT": a(i) = "S"
      Case "ACA", "ACC", "ACG", "ACT": a(i) = "T"
      Case "GTA", "GTC", "GTG", "GTT": a(i) = "V"
      Case "TGG": a(i) = "W"
      Case "TAC", "TAT": a(i) = "Y"
      Case "TAA", "TAG", "TGA": Exit For
      Case Else: a(i) = "?(" & sCodon & ")" ' comment to skip this line
    End Select
  Next
  
  Translation3 = Join(a, vbNullString)
  
End Function

Private Sub Test1_Translation3()
  Const Codon$ = "ATG"
  Dim Txt$
  'Txt = ThisWorkbook.Sheets(1).Range("C2").Value
  Txt = "ATGGATCCAATGACTGATGTGTCAAGATGCTTTCAGGTAGATTATGGCTTTCTTTGGATGCATGTCCGCAAATACGAATGGTTGCAGACTTAA"
  
  Debug.Print "Txt", Txt
  Debug.Print
  
  Debug.Print "Frame = 1 to 3"
  Debug.Print "Fr1", Translation3(Txt)
  Debug.Print "Fr2", Translation3(Txt, 2)
  Debug.Print "Fr3", Translation3(Txt, 3)
  Debug.Print
  
  Debug.Print "Frame = 1 to 3, Codon = " & Chr(34) & Codon & Chr(34)
  Debug.Print "Fr1 ", Translation3(Txt, 1, Codon)
  Debug.Print "Fr2 ", Translation3(Txt, 2, Codon)
  Debug.Print "Fr3 ", Translation3(Txt, 3, Codon)
  Debug.Print
  
  Debug.Print "Frame = 1, Codon = " & Chr(34) & Codon & Chr(34) & ", EntryStartCodon = 1 to 3"
  Debug.Print "Fr1 Ent1", Translation3(Txt, 1, Codon, 1)
  Debug.Print "Fr1 Ent2", Translation3(Txt, 1, Codon, 2)
  Debug.Print "Fr1 Ent3", Translation3(Txt, 1, Codon, 3)
  Debug.Print
  
  Debug.Print "Frame = 2, Codon = " & Chr(34) & Codon & Chr(34) & ", EntryStartCodon = 1 to 3"
  Debug.Print "Fr2 Ent1", Translation3(Txt, 2, Codon, 1)
  Debug.Print "Fr2 Ent2", Translation3(Txt, 2, Codon, 2)
  Debug.Print "Fr2 Ent3", Translation3(Txt, 2, Codon, 3)
  Debug.Print
  
  Debug.Print "Frame = 3, Codon = " & Chr(34) & Codon & Chr(34) & ", EntryStartCodon = 1 to 3"
  Debug.Print "Fr3 Ent1", Translation3(Txt, 3, Codon, 1)
  Debug.Print "Fr3 Ent2", Translation3(Txt, 3, Codon, 2)
  Debug.Print "Fr3 Ent3", Translation3(Txt, 3, Codon, 3)
    
End Sub