Se está querendo criar um loop, é só se basear no loop criado no exemplo que te enviei no tópico abaixo.

Antes, apague da rotina Encripta a linha que seleciona o Range A1, depois insira as instruções para capturar a última linha e a que define o Range e substitua a linha que está definindo o Loop na rotina Encripta - For Each c In Selection por For Each c In sRG

viewtopic.php?f=10&t=20648&start=10

[]s

Coutinho, estou tentando acertar essa linha " Set sRg = Range("A2" & ":" & "A" & ultLin) ", sem sucesso.

Sub Encripta()

Dim xEnds
Dim sRg As Range
Dim ultLin

'Range("a1").Select

ultLin = Range("A" & Rows.Count).End(xlUp).Row

Set sRg = Range("A2" & ":" & "A" & ultLin) --> sei que não é dessa forma aqui, essa linha está incrementando.

Application.ScreenUpdating = False

For Each xEnds In sRg

On Error Resume Next
Dim c As Range, i As Long, sCode As String, sCode2 As String
Application.ScreenUpdating = False

'For Each c In Selection

For Each c In sRg

If LowerCase = True Then c = LCase(c)

For i = 1 To Len(c) + 2
If i Mod 2 = 0 Then
sCode = sCode & Mid(c, i, 1)
Else
sCode = sCode & Mid(c, i - 2, 1)
End If
Next
For i = Len(sCode) To 1 Step -1
sCode2 = sCode2 & Chr(Asc(Mid(sCode, i, 1)) + 1)
Next
c = sCode2
Next
Application.ScreenUpdating = True
For i = Len(sCode) To 1 Step -1
sCode2 = sCode2 & Chr(Asc(Mid(sCode, i, 1)) + 1)
Next

[a1].Select

Next xEnds

End Sub

Carlos, como citei acima:

substitua a linha que está definindo o Loop na rotina Encripta - For Each c In Selection por For Each c In sRG

E você em vez disto acrescentou mais um Loop : For Each xEnds In sRg era para você procurar analisar e entender o processo de Loop criado naquela rotina e só substituir o xEnds pelo c e o Selection por sRg.

Adicionei duas linhas para "zerar" o valor armazenado anteriormente, que da forma que está estamos juntando a cada palavra a anterior com a atual, se não for isto, só elimine as linhas:
sCode2 = ""
sCode = ""

Acho que tirou esta rotina do link abaixo:
Excel planilha vba dados encripta desencripta frase
http://www.microsoftexcel.com.br/index. ... frase.html
Se foi, acostume-se de indicar a fonte.

No código deixei desabilitado as linhas que você havia acrescentado, só para entender onde estava o erro:

Sub EncriptaMauro()

'Dim xEnds
Dim sRg As Range
Dim ultLin

'Range("a1").Select

ultLin = Range("A" & Rows.Count).End(xlUp).Row

Set sRg = Range("A2" & ":" & "A" & ultLin)

'For Each xEnds In sRg

    On Error Resume Next
    Dim c As Range, i As Long, sCode As String, sCode2 As String
    
    Application.ScreenUpdating = False
    
    For Each c In sRg
    
        If LowerCase = True Then c = LCase(c)
        
            For i = 1 To Len(c) + 2
                If i Mod 2 = 0 Then
                sCode = sCode & Mid(c, i, 1)
                Else
                sCode = sCode & Mid(c, i - 2, 1)
                End If
            Next
            
            For i = Len(sCode) To 1 Step -1
                sCode2 = sCode2 & Chr(Asc(Mid(sCode, i, 1)) + 1)
            Next
            
            c = sCode2
            
            'Limpamos os valores armazenados
            sCode2 = ""
            sCode = ""
        
        Next
        
            Application.ScreenUpdating = True
        
            For i = Len(sCode) To 1 Step -1
                sCode2 = sCode2 & Chr(Asc(Mid(sCode, i, 1)) + 1)
            Next

'Next xEnds

End Sub

[]s

Bom-dia.
Obrigado Mauro...!!!

Att,

Francisco