Iniciar sesiónCerrar
Correo:
Contraseña:
Entrar
Recordar sesión en este navegador
Iniciar sesiónIniciar sesiónCrear cuentaCrear cuenta
LWP » Foros » Excel » macro que busca y copia un rango y lo pega con su formato real, no solo el texto sin más

Excel - macro que busca y copia un rango y lo pega con su formato real, no solo el texto sin más

Volver
Nuevo Tema
<<>>
 
Vista:
Imágen de perfil de celia
Val: 761
Bronce
Ha mantenido su posición en Excel (en relación al último mes)
Gráfica de Excel

macro que busca y copia un rango y lo pega con su formato real, no solo el texto sin más

Publicado por celia (437 intervenciones) el 19/03/2019 08:54:20
Hola.
Pido ayuda de nuevo porque no consigo resolver este código que busca un rango y lo pega muy bien en la misma hoja pero me copia solo el texto en negro y quería que pegara también los colores de las celdas del rango encontrado.

Copio el código de los 2 módulos que tiene y el de la hoja llamada Sheet (VA)
Adjunto el archivo también porque en mi pregunta anterior se me pasó hacerlo el mismo día.
Gracias de nuevo.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
---- Módulo 1:
 
Sub actualiza_tabla()
 
' actualiza_tabla Macro

 
Range("M7:N7").Select
Selection.Copy
Range("A2").Select
Application.CutCopyMode = False
End Sub
 
 
 
          ----- Módulo 2:
 
Option Explicit
Public Function MiEvento(rngCelda As Range)
Range("seleccion").Value = rngCelda.Value
Call Copiar_Tabla("")
MsgBox " 0 "
End Function
 
Public Function MiEvento_1(rngCelda As Range)
Range("q4").Value = rngCelda.Value
Call Copiar_Tabla("")
MsgBox " 1 "
End Function
 
Public Function MiEvento_2(rngCelda As Range)
Range("q11").Value = rngCelda.Value
End Function
 
Public Function MiEvento_3(rngCelda As Range)
Range("J14").Value = rngCelda.Value
End Function
 
 
Public Function BuscarTT(CeldaBusqueda As Range, RangoTexto As Range, Columna As Integer)
 
On Error Resume Next
Dim VTexto, Valor: Dim R0, C0, R, c As Integer
 
VTexto = RangoTexto
R0 = RangoTexto.Row: C0 = RangoTexto.Column
 
R = Cells.Find(What:=VTexto, After:=CeldaBusqueda, LookIn:=xlValues, lookAt:=xlWhole).Row
c = Cells.Find(What:=VTexto, After:=CeldaBusqueda, LookIn:=xlValues, lookAt:=xlWhole).Column
c = c + Columna
 
If Err.Number = 0 And R0 <> R Then Valor = Cells(R, c) Else: Valor = "No Sé"
BuscarTT = Valor
 
End Function
 
Public Sub Copiar_Tabla(Nulo As String)
Dim Fila_Destin As Long, f As Long, Fil As Long, Texto As String, _
Colu_Destin As Long, c As Long, Col As Long
 
Fila_Destin = 43
Colu_Destin = 4
 
Texto = Range("M7"): Tabla = ""
 
For Fil = 41 To 579 Step 15
For Col = 50 To 134 Step 14
If Texto = Cells(Fil, Col) Then
For f = 0 To 12
For c = 0 To 12
Cells(f + Fila_Tabla_Destin, c + Colu_Tabla_Destin) = Cells(f + Fil, c + Col)
Next
Next
Exit For
End If
Next
If Len(Tabla) > 0 Then Exit For
Next
Cells(21, "D") = Timer
End Sub
 
 
 
      ----- código de la Hoja Sheet (VA):
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Fila_Destin As Long, f As Long, Texto As String, _
Colu_Destin As Long, c As Long
 
Dim Lin As Integer, Col As Integer
 
Col = Target.Column
Fil = Target.Row
 
If Col >= 65 And Col <= 77 And Fil >= 3 And Fil <= 15 Then Cells(6, 13) = Target.Value
If Col >= 65 And Col <= 77 And Fil >= 3 And Fil <= 15 Then Cells(12, 13) = Target.Value
If Col >= 18 And Col <= 30 And Fil >= 3 And Fil <= 15 Then Cells(6, 13) = Target.Value
If Col >= 18 And Col <= 30 And Fil >= 3 And Fil <= 15 Then Cells(12, 13) = Target.Value
 
' ---&---

 
If Col = 13 And Fil = 7 Then
Texto = Cells(7, "M")
 
Fila_Destin = 42
Colu_Destin = 4
 
For Fil = 42 To 580 Step 15
For Col = 37 To 134 Step 14
If Texto = Cells(Fil, Col) Then
For f = 0 To 12
For c = 0 To 12
Cells(f + Fila_Destin, c + Colu_Destin) = Cells(f + Fil, c + Col)
Next
Next
Exit Sub
End If
Next
Next
End If
End Sub
Valora esta pregunta
Me gusta: Está pregunta es útil y esta claraNo me gusta: Está pregunta no esta clara o no es útil
0
Responder
Imágen de perfil de Antoni Masana
Val: 4.908
Oro
Ha mantenido su posición en Excel (en relación al último mes)
Gráfica de Excel

macro que busca y copia un rango y lo pega con su formato real, no solo el texto sin más

Publicado por Antoni Masana (2540 intervenciones) el 19/03/2019 13:20:04
Cuando se ejecuta la macro Actualizar_Tabla cada vez que haces un Select se ejecuta la macro Worksheet_SelectionChange por una lado y haces un copy pero no haces un paste

1
2
3
4
5
6
7
8
9
Sub actualiza_tabla()
 
    ' actualiza_tabla Macro

 
    Range("M7:N7").Select
    Selection.Copy
    Range("A2").Select
    Application.CutCopyMode = False
End Sub

Esto soluciona el problema pero no se si es lo que deseas

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub actualiza_tabla()
'

' actualiza_tabla Macro

'

 
    Application.EnableEvents = False
    Range("M7:N7").Select
    Selection.Copy
    Range("A2").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Application.EnableEvents = True
End Sub

Saludos.
\\//_
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
2
Comentar
Imágen de perfil de celia
Val: 761
Bronce
Ha mantenido su posición en Excel (en relación al último mes)
Gráfica de Excel

macro que busca y copia un rango y lo pega con su formato real, no solo el texto sin más

Publicado por celia (437 intervenciones) el 19/03/2019 13:47:54
Eso arregla otra cosa sí, pero lo que quería es que copie la tabla en colores al elegir por ejemplo la tabla 1 pulsando sobre la letra A y el número 1 que saliera tal cual es con sus colores. Adjunto foto de como sale ahora y cómo debería salir.
No sé nada de código pero en la celda D42 se pega la tabla que busca la macro al picar sobre una letra y un número del cuadro de arriba y si no usa copiar y pegar debe hacerlo de otra forma pero solo falta que al pegar esos datos los pegara en color.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
Imágen de perfil de Antoni Masana
Val: 4.908
Oro
Ha mantenido su posición en Excel (en relación al último mes)
Gráfica de Excel

macro que busca y copia un rango y lo pega con su formato real, no solo el texto sin más

Publicado por Antoni Masana (2540 intervenciones) el 19/03/2019 20:51:43
Veo que donde haces la copia es en la macro Worksheet_SelectionChange .
He realizado unos cambios, creo que el destino de la copia es D42 .
Si el Select funciona lo demás también.

Marco los cambios en negrita.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Fila_Destin As Long, f As Long, Texto As String, _
    Colu_Destin As Long, c As Long
 
    Dim Lin As Integer, Col As Integer
 
    Col = Target.Column
    Fil = Target.Row
 
    If Col >= 65 And Col <= 77 And Fil >= 3 And Fil <= 15 Then Cells(6, 13) = Target.Value
    If Col >= 65 And Col <= 77 And Fil >= 3 And Fil <= 15 Then Cells(12, 13) = Target.Value
    If Col >= 18 And Col <= 30 And Fil >= 3 And Fil <= 15 Then Cells(6, 13) = Target.Value
    If Col >= 18 And Col <= 30 And Fil >= 3 And Fil <= 15 Then Cells(12, 13) = Target.Value
 
    ' ---&---

 
    Application.EnableEvents = False
    If Col = 13 And Fil = 7 Then
        Texto = Cells(7, "M")
        Fila_Destin = 42
        Colu_Destin = 4
 
        For Fil = 42 To 580 Step 15
            For Col = 37 To 134 Step 14
                If Texto = Cells(Fil, Col) Then
                    Range(Cells(Fil,Col), Cells((Fil+12),(Col+12))).Select
                    Selection.Copy
                    Range("D42").Select
                    ActiveSheet.Paste
                    Application.CutCopyMode = False
                    Application.EnableEvents = True
                    Exit Sub
                End If
            Next
        Next
    End If
    Application.CutCopyMode = False
    Application.EnableEvents = True
End Sub

Saludos.
\\//_
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
2
Comentar
Imágen de perfil de celia
Val: 761
Bronce
Ha mantenido su posición en Excel (en relación al último mes)
Gráfica de Excel

macro que busca y copia un rango y lo pega con su formato real, no solo el texto sin más

Publicado por celia (437 intervenciones) el 19/03/2019 22:57:58
Genial Antoni !!!!

Me alegraste el día al resolver este problema que ya me parecía imposible de resolver.
Muchísima gracias por tu tiempo y amabilidad.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar