Busqueda con repeticiones

[yordin]

buenas tardes necesito una ayuda con una macro para buscar datos en una base de datos pero cuando el código buscado se repite solo me extrae los datos del primero necesito ayuda que cuando se repita me emita algún listado de cuales son los q se repiten y cual deseo usar

la macro es la siguiente:

Sub Buscar()

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

Application.EnableEvents = False

ActiveSheet.DisplayPageBreaks = False

Sheets("BUSCAR").Unprotect ("17919119")

Dim WS As Worksheet

Dim rBingo As Range

Borrar_Form

For Each WS In ThisWorkbook.Worksheets

If WS.Name Like "Dir*" Then

Set rBingo = WS.Cells.Find(What:=[Codigo], LookAt:=xlWhole)

If Not rBingo Is Nothing Then Exit For

End If

Next WS

If rBingo Is Nothing Then

' No encontrado

MsgBox "Código " & [Codigo] & " no encontrado", vbInformation, "AM Consultores"

Else

Copiar_datos WS, rBingo.Row

Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic

Application.EnableEvents = True

ActiveSheet.DisplayPageBreaks = True

Application.CutCopyMode = False

End If

End Sub

[Gerson Pineda]

buenas tardes necesito una ayuda con una macro para buscar datos en una base de datos pero cuando el código buscado se repite solo me extrae los datos del primero necesito ayuda que cuando se repita me emita algún listado de cuales son los q se repiten y cual deseo usar

la macro es la siguiente:

Sub Buscar()

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

Application.EnableEvents = False

ActiveSheet.DisplayPageBreaks = False

Sheets("BUSCAR").Unprotect ("17919119")

Dim WS As Worksheet

Dim rBingo As Range

Borrar_Form

For Each WS In ThisWorkbook.Worksheets

If WS.Name Like "Dir*" Then

Set rBingo = WS.Cells.Find(What:=[Codigo], LookAt:=xlWhole)

If Not rBingo Is Nothing Then Exit For

End If

Next WS

If rBingo Is Nothing Then

' No encontrado

MsgBox "Código " & [Codigo] & " no encontrado", vbInformation, "AM Consultores"

Else

Copiar_datos WS, rBingo.Row

Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic

Application.EnableEvents = True

ActiveSheet.DisplayPageBreaks = True

Application.CutCopyMode = False

End If

End Sub

@[uSER=173994]yordin[/uSER]

Porfavor debes entender a cabalidad las normas del foro, como tambien debes envolver con etiquetas los codigos o formulas, por ejemplo este

Sub Buscar()

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

Application.EnableEvents = False

ActiveSheet.DisplayPageBreaks = False

Sheets("BUSCAR").Unprotect ("17919119")

Dim WS As Worksheet

Dim rBingo As Range

Borrar_Form

For Each WS In ThisWorkbook.Worksheets

If WS.Name Like "Dir*" Then

Set rBingo = WS.Cells.Find(What:=[Codigo], LookAt:=xlWhole)

If Not rBingo Is Nothing Then Exit For

End If

Next WS

If rBingo Is Nothing Then

' No encontrado

MsgBox "Código " & [Codigo] & " no encontrado", vbInformation, "AM Consultores"

Else

Copiar_datos WS, rBingo.Row

Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic

Application.EnableEvents = True

ActiveSheet.DisplayPageBreaks = True

Application.CutCopyMode = False

End If

End Sub[/CODE]

Desde ya tienes que entender que no solo es cuestion de publicar un tema para preguntar como sea, en este tema te hace falta algo muy importante

Saludos