Revalorizar contenido de celdas con macro
Necesito revalorizar el contenido de unas celdas de excel que contienen valores en pesos y las quiero valorizar en otra moneda como el Euro, para ello requiero multiplicarlo por un valor X ejemplo valor del Euro. Los nuevos valores deben quedar en los mismos rangos de celdas. Osea aplastar los valores en pesos, pero también debo poder volver a los valores originales en algún momento. ¿Es posible realizarlo con una macro ejecutable?
Rango celda B2 a la F8
1 Respuesta
De acuerdo a tu información tus datos a revalorizar están en B2 a F8, como se muestra en la siguiente imagen:
Funciona de la siguiente manera:
1. Debes tener 2 hojas: Hoja1 con los valores y Hoja2 para guardar los valores originales.
2. En la celda A2 debes capturar la palabra "Pesos"
3. En la celda A5 debes capturar el valor del Euro
4. Asigna la macro "Revalorizar" al botón "Revalorizar"
5. Asigna la macro "Originales" al botón "Originales"
Sub Revalorizar()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim r As String
Set sh1 = Sheets("Hoja1")
Set sh2 = Sheets("Hoja2")
r = "B2:F8"
If sh1.Range("A2").Value = "Pesos" Then
If sh1.Range("A5").Value <> "" And IsNumeric(sh1.Range("A5").Value) Then
sh1.Range(r).Copy sh2.Range(r)
sh1.Range("A5").Copy
sh1.Range(r).PasteSpecial xlPasteAll, xlPasteSpecialOperationMultiply
Range("A2").Value = "Euros"
Application.CutCopyMode = False
Range("A2").Select
Else
MsgBox "Falta el valor del Euro"
Range("A5").Select
End If
Else
MsgBox "No puedes volver a revalorizar"
End If
End SubSub Originales()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim r As String
Set sh1 = Sheets("Hoja1")
Set sh2 = Sheets("Hoja2")
r = "B2:F8"
sh2.Range(r).Copy sh1.Range(r)
Range("A2").Value = "Pesos"
End Sub6. Presiona el botón "Revalorizar".
La macro copia los valores originales a la hoja2. Convierte los valores a Euros. Cambia la celda A2 a "Euros".
7. Si presionas nuevamente el botón "Revalorizar", te aparece un mensaje "No puedes volver a revalorizar".
8. Presiona el botón "Originales", los valores originales regresan a la hoja1.
Realiza todos los pasos y prueba las macros. Después de realizar las pruebas me comentas si requieres algún cambio.
Hola Dante
Gracias por tu respuesta.
Te cuento que es lo requería y funciona muy bien. Sólo un detalle quiero adicionar otro rango de celda no continuo al proceso. Osea que además de la(" B2:F8" ) adicionar (J2:J8) y (E16) y (J16)
Van los 2 códigos, no olvides valorar la respuesta
Sub Revalorizar()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim rngs As Variant, r As Variant
'
Application.ScreenUpdating = False
Set sh1 = Sheets("Hoja1")
Set sh2 = Sheets("Hoja2")
rngs = Array("B2:F8", "J2:J8", "E16", "J16")
'
If sh1.Range("A2").Value = "Pesos" Then
If sh1.Range("A5").Value <> "" And IsNumeric(sh1.Range("A5").Value) Then
For Each r In rngs
sh1.Range(r).Copy sh2.Range(r)
sh1.Range("A5").Copy
sh1.Range(r).PasteSpecial xlPasteAll, xlPasteSpecialOperationMultiply
Next
Range("A2").Value = "Euros"
Application.CutCopyMode = False
Range("A2").Select
Else
MsgBox "Falta el valor del Euro"
Range("A5").Select
End If
Else
MsgBox "No puedes volver a revalorizar"
End If
Application.ScreenUpdating = True
End SubSub Originales()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim rngs As Variant, r As Variant
'
Set sh1 = Sheets("Hoja1")
Set sh2 = Sheets("Hoja2")
rngs = Array("B2:F8", "J2:J8", "E16", "J16")
For Each r In rngs
sh2.Range(r).Copy sh1.Range(r)
Next
'
Range("A2").Value = "Pesos"
End Sub
