| Descricao: |
 Saberexcel - O site das Macros
Essas macros do Aplicativo Microsoft Excel VBA, encripta e desencripta uma determinada frase em uma célula da folha de planilha
Sub Encripta()
Range("e7").Select
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
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
[f12].Select
End Sub
Sub Desencripta()
Range("e7").Select
On Error Resume Next
Dim c As Range, i As Long, sCode As String, sCode2 As String, sCode3 As String
Application.ScreenUpdating = False
For Each c In Selection
sCode = ""
sCode2 = ""
sCode3 = ""
For i = Len(c) To 1 Step -1
sCode = sCode & Mid(c, i, 1)
Next
For i = 1 To Len(sCode) + 2
If i Mod 2 = 0 Then
sCode2 = sCode2 & Mid(sCode, i, 1)
Else
sCode2 = sCode2 & Mid(sCode, i - 2, 1)
End If
Next
For i = 1 To Len(sCode2)
sCode3 = sCode3 & Chr(Asc(Mid(sCode2, i, 1)) - 1)
Next
c = sCode3
Next
Application.ScreenUpdating = True
sCode = ""
sCode2 = ""
sCode3 = ""
For i = Len(TextBoxCode) To 1 Step -1
sCode = sCode & Mid(TextBoxCode, i, 1)
Next
For i = 1 To Len(sCode) + 2
If i Mod 2 = 0 Then
sCode2 = sCode2 & Mid(sCode, i, 1)
Else
sCode2 = sCode2 & Mid(sCode, i - 2, 1)
End If
Next
For i = 1 To Len(sCode)
sCode3 = sCode3 & Chr(Asc(Mid(sCode2, i, 1)) - 1)
Next
' TextBoxCode = sCode3
[f12].Select
End Sub
Aprenda tudo sobre o Aplicativo Microsoft Excel VBA com SaberExcel
Publicidade
Compre com segurança, garantia e ótimos preços nas lojas Submarino 
|