miércoles, 13 de marzo de 2013

MACRO BUSCAR Y COPIAR

Sub buscarcancion()
' Por Dam
' Busca canciones por una palabra y las copia a otra hoja
'
Application.ScreenUpdating = False
Dim ufila, ucolumna As Long
canción = InputBox(Prompt:="Canción o palabra:")
j = 2
una vez = 1
ultimo = 0
Sheets("BÚSQUEDA").Select
ActiveSheet.Cells.Clear
Sheets("DATOS").Select
ufila = ActiveCell.SpecialCells(xlLastCell).Row
ucol = ActiveCell.SpecialCells(xlLastCell).Column
Range(Cells(1, 1), Cells(1, ucol)).Select
Selection.Copy
Sheets("BÚSQUEDA").Select
Cells(1, 1).Select
ActiveSheet.Paste
Sheets("DATOS").Select
For i = 1 To ufila
Range(Cells(i, 1), Cells(ufila, 1)).Select
If una vez = 1 Then
Set RangoObj = Selection.Find(What:=canción, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
If RangoObj Is Nothing Then
MsgBox ("No se encontró " & canción)
Exit For
End If
End If
una vez = 2
Set RangoObj = Selection.FindNext(After:=ActiveCell)
If RangoObj Is Nothing Then
MsgBox ("Fin de la Búsqueda de '" & canción & _
"'. Se encontraron " & j - 2 & " Canciones")
ultimo = 1
Exit For
Else
i = RangoObj.Row
Range(Cells(i, 1), Cells(i, ucol)).Select
Selection.Copy
Sheets("BÚSQUEDA").Select
Cells(j, 1).Select
ActiveSheet.Paste
j = j + 1
Sheets("DATOS").Select
End If
Next
Sheets("BÚSQUEDA").Select
If ultimo = 0 Then
MsgBox ("Fin de la Búsqueda de '" & canción & _
"'. Se encontraron " & j - 2 & " Canciones")
End If
Application.ScreenUpdating = True
End Sub

No hay comentarios:

Publicar un comentario