Replicar Macro de Excel a dos hojas distintas del mismo libro
Tengo un libro con una macro en una hoja (mapa) y quiero copiar la misma macro a otra hoja (Hoja2) y que me haga lo mismo pero con los datos de la Hoja2. Mi problema es que cuando le doy a copiar hoja, la hoja “mapa” se me actualiza con los datos de la hoja Hoja2 además de con los de la hoja “mapa”.
Esta es la macro:
Sub colorprov()
Dim Provin As String
Dim intColourLookup As Integer
Dim rngProv As Range
Dim rngColor As Range
Set rngProv = Range(ThisWorkbook.Names("provincias").RefersTo)
Set rngColor = Range(ThisWorkbook.Names("colores").RefersTo)
With Worksheets("mapa")
For i = 1 To rngProv.Rows.Count
Provin = rngProv.Cells(i, 1).Text
valor = rngProv.Cells(i, 2).Value
With .Shapes(Provin)
.Fill.Solid
.Fill.ForeColor.RGB = rngColor.Cells(valor, 1).Offset(0, 1).Interior.Color
End With
Next
End With
End Sub
Muchas gracias!
Para lo que haces deberías poner la macro en un módulo (menú insertar-módulo). Estando así la macro será para todo el libro.
En el código pones "worksheets("mapa")". Eso claramente hace referencia a la página "mapa" pero si quieres hacer referencia a la página activa debes poner "ActiveSheet". Cambia la línea:
With Worksheets("mapa")
por:
With ActiveSheet
No me lo hace correctamente, el problema es que me realiza la macro pero con los datos de la hoja "mapa". Ya había probado con ActiveSheet y, o me da error o me lo hace con los datos de otra hoja :S
Supongo que el error te lo dará en:
With .Shapes(Provin)
Si quieres sube la hoja de cálculo a un disco virtual (por ejemplo dropbox) y me mandas el enlace para verlo.
https://www.dropbox.com/s/vrg8e7xlwr85lyf/mapa-de-espana.xls
Muchísimas gracias!!
No sé si entiendo bien lo que quieres, pero haciendo lo que te comentaba de usar "activesheet" creo que funciona.
He subido a dropbox tu hoja de cálculo con 2 páginas nuevas: una creada como copia de "mapa" que se llama "mapa2" y otra "hoja2" creada en blanco en la cual he copiado los objetos y celdas de mapa y, que no se olvide, he definido a mano el área de provincias y colores.
La hoja de cálculo está en este enlace:
https://www.dropbox.com/s/9oheoxxq0aebdl0/mapa-de-espana.xls
Espero que sea eso lo que quieres.
Por cierto, ¿qué versión usas de Excel? Por la extensión parece que no pasas de la 2003 porque si es posterior debería llevar extensión ".xlsm".
He abierto otra vez la hoja de cálculo y... ahora no me funcionaba. Daba el problema que tú indicas.
He preparado este código que, esta vez creo que sí, me parece que hace lo que quieres:
Option Explicit
Sub colorprov()
'
' Using the values from named range STATE
' And the colours from named range STATE_COLOURS
' re colour the map on sheet MainMap
'
Dim Provin As String
Dim intColourLookup As Integer
Dim rngProv As Range
Dim rngColor As Range
Dim i As Integer
Dim valor As Variant
Dim aux As String
' Buscamos el rango de celdas del nombre definido
aux = seleccionaRangoNombre("provincias", ActiveSheet.Name)
If aux = "" Then Exit Sub
Set rngProv = ActiveSheet.Range(aux)
aux = seleccionaRangoNombre("colores", ActiveSheet.Name)
If aux = "" Then Exit Sub
Set rngColor = ActiveSheet.Range(aux)
With ActiveSheet
For i = 1 To rngProv.Rows.Count
Provin = rngProv.Cells(i, 1).Text
valor = rngProv.Cells(i, 2).Value
With ActiveSheet.Shapes(Provin)
.Fill.Solid
.Fill.ForeColor.RGB = rngColor.Cells(valor, 1).Offset(0, 1).Interior.Color
End With
Next
End With
End Sub
Function seleccionaRangoNombre(ByVal nomRango As String, ByVal nomPagina As String) As String
Dim r As Range
Dim i As Integer
Dim aux As String
Dim aux2 As String
Dim txtRango As String
For i = 1 To ThisWorkbook.Names.Count
aux = UCase$(ThisWorkbook.Names(i).Name)
aux2 = UCase$(ThisWorkbook.Names(i).RefersTo)
' Si el nombre es el de la página seguido de "!" y seguido del rango, es el buscado
If aux = UCase$(nomPagina) & "!" & UCase$(nomRango) Then Exit For ' Encontrado
' También lo damos por encontrado si el nombre es el del rango sin la página delante
' y las celdas a las que se refiere son de la página indicada (empieza por "=" seguido
' del nombre de la página y seguido de "!"
If aux = UCase$(nomRango) And _
Left$(aux2, Len(nomPagina) + 2) = "=" & nomPagina & "!" Then Exit For ' Encontrado
Next i
' Si hemos encontrado el rango en la página...
' lo asignamos y terminamos.
If i <= ThisWorkbook.Names.Count Then
' OJO: aux2 contiene el carácter "=" al inicio, seguido del nombre de página y el
' carácter "!". Después va el rango de las celdas. Quitamos todo ese inicio
If Left$(aux2, 1) = "=" Then aux2 = Right$(aux2, Len(aux2) - 1)
If InStr(aux2, "!") > 0 Then aux2 = Right$(aux2, Len(aux2) - InStr(aux2, "!"))
seleccionaRangoNombre = aux2
Exit Function ' Ya tenemos lo que buscábamos
End If
' Si no lo ha encontrado en la página que queres, probamos a buscar el nombre en cualquier
' página y devolveremos el mismo rango de celdas de nuestra página que el
' marcado en la página encontrada
For i = 1 To ThisWorkbook.Names.Count
' Miramos el nombre definido y, si tiene el nombre de la página delante del "!", lo quitamos
aux = UCase$(ThisWorkbook.Names(i).Name)
If InStr(aux, "!") > 0 Then aux = Right$(aux, Len(aux) - InStr(aux, "!"))
' Hacemos lo mismo con el rango de celdas a las que se refiere pero... antes de quitar el
' nombre de la página quitamos siempre el carácter "="
aux2 = UCase$(ThisWorkbook.Names(i).RefersTo)
If Left$(aux2, 1) = "=" Then aux2 = Right$(aux2, Len(aux2) - 1)
If InStr(aux2, "!") > 0 Then aux2 = Right$(aux2, Len(aux2) - InStr(aux2, "!"))
' Si el nombre (aux) es el de la página, devolveremos el mismo rango de celdas (aux2) referido
' a la página activa
If aux = UCase$(nomRango) Then ' Encontrado
seleccionaRangoNombre = aux2
Exit Function
End If
Next i
' Si sale por aquí es que no ha encontrado nada
MsgBox "Nombre '" & nomRango & "' no encontrado en la página '" & nomPagina & "' ni en ninguna otra. Proceso cancelado."
seleccionaRangoNombre = ""
End Function
Muchísimas gracias!!!! Lejos de entender la solución que me has dado te agradezco enormemente tu tiempo! Es increíble y nunca hubiese podido hacerlo yo sola.
Muchas gracias
