Macro copia celdas según su color de fondo.
Tengo una gran necesidad que no he podido resolver, tengo en la hoja1 en el rango A8:Ac40, varios datos de trabajo que los identificó por 4 colores, amarillo, rojo, verde y azul celeste, necesito una macro que pueda copiar por colores y me los pegue en la hoja2, colomna A, B, C, D. Aquí te dejo el código de una macro tuya, que encontré en la red. Algo así es lo que estoy necesitando, pero solo busca y copia en la columna "D" y en la " E" y pega los datos en la hoja2 colomna B y E. Yo necesito que me busque en el rango antes mencionado. Este es tu código:
Sub macrocolor ()
Application.ScreenUpdating = False
'ufila = Range("A" & Rows.Count).End(xlUp).Row
Sheets("Hoja1").Select
ufila = 88
j = 4
For i = 5 To ufila
Cells(i, 4).Select
numcolor = ActiveCell.Interior.ColorIndex
Select Case numcolor
Case 3 'rojo copia y pega en la hoja2-B
Selection.Copy
Sheets("Hoja2").Select
Range("B" & i).Select
ActiveSheet.Paste
j = j + 1
Case 6 'amarillo copia y pega en la hoja2-E
Selection.Copy
Sheets("Hoja2").Select
Range("E" & i).Select
ActiveSheet.Paste
Case 4
End Select
Sheets("Hoja1").Select
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub.
1 respuesta
H o la :
Y cómo quieres el pegado, todos los amarillos en la columna A, los rojos en la B, los verdes en la C y los azules en la D.
Como bien sabes los colores tiene un número de identificación. Envíame tu archivo con ejemplos para ver el número de cada color.
Mi correo [email protected]
En el asunto del correo escribe tu nombre de usuario “V.G.Petro G.P” y el título de esta pregunta.
hola Dante, le envié el archivo. El pegado va de la siguiente manera: los amarillos en la columna A, los rojos en la B, los verdes en la C y los azules en la D.
Los números de identificación de los colores son: Amarillo = 6. Rojo = 3. Verde = 14. Azul = 23. En la hoja1, en Cada casilla tiene un dato numérico introducido manualmente, bueno si es posible que al momento del pegado en la hoja2, lo haga en orden de menor al mayor numero.
Muchas gracias por ayudarme.
H o l a:
Te anexo la macro
Sub Copia_Color()
'---
' Por.Dante Amor
'---
Application.ScreenUpdating = False
Set h1 = Sheets("Hoja1")
Set h2 = Sheets("Hoja2")
h2.Range("A6:D" & Rows.Count).Clear
For Each celda In h1.Cells.SpecialCells(xlCellTypeConstants, 23)
Select Case celda.Interior.ColorIndex
Case 6: col = "A" 'Amarillo
Case 3: col = "B" 'Rojo
Case 14: col = "C" 'Verde
Case 23: col = "D" 'Azul
Case Else: col = ""
End Select
If col <> "" Then
u = h2.Cells(Rows.Count, col).End(xlUp).Row + 1
celda.Copy h2.Cells(u, col)
End If
Next
For i = 1 To 4
u = h2.Cells(Rows.Count, i).End(xlUp).Row
With h2.Sort
.SortFields.Clear
.SortFields.Add Key:=h2.Cells(5, i), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange h2.Range(h2.Cells(6, i), h2.Cells(u, i)): .Header = xlNo
.MatchCase = False: .Orientation = xlTopToBottom
.SortMethod = xlPinYin: .Apply
End With
Next
Application.ScreenUpdating = True
MsgBox "Fin"
End Sub
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
