Problemas con Excel ya que quiero buscar y copiar celdas en otra hoja

Sub transferirDatosOtraHoja()
Dim ID As String
Dim NIT As String
Dim RAZONSOCIAL As String
Dim NOMBRES As String
Dim APELLIDOS As String
Dim DIRECCION As String
Dim CONTACTO As String
Dim TELEFONO1 As String
Dim TELEFONO2 As String
Dim DESCRIPCION As String
Dim ultimaFila As Long
Dim ultimaFilaAuxiliar As Long
Dim cont As Long
Dim palabraBusqueda As String
palabraBusqueda = Sheets("HERMANDAD").Cells(3, 16)
palabraBusqueda = "*" & palabraBusqueda & "*"
ultimaFila = Sheets("HERMANDAD").Range("A" & Rows.Count).End(xlUp).Row
If ultimaFila < 1 Then
Exit Sub
End If
For cont = 2 To ultimaFila
If Sheets("HERMANDAD").Cells(cont, 1) Like BUSQUEDAPARAIMPRESIÓN Then
If Sheets("HERMANDAD").Cells(cont, 2) Like BUSQUEDAPARAIMPRESIÓN Then
If Sheets("HERMANDAD").Cells(cont, 3) Like BUSQUEDAPARAIMPRESIÓN Then
If Sheets("HERMANDAD").Cells(cont, 4) Like BUSQUEDAPARAIMPRESIÓN Then
If Sheets("HERMANDAD").Cells(cont, 5) Like BUSQUEDAPARAIMPRESIÓN Then
If Sheets("HERMANDAD").Cells(cont, 6) Like BUSQUEDAPARAIMPRESIÓN Then
If Sheets("HERMANDAD").Cells(cont, 7) Like BUSQUEDAPARAIMPRESIÓN Then
If Sheets("HERMANDAD").Cells(cont, 8) Like BUSQUEDAPARAIMPRESIÓN Then
If Sheets("HERMANDAD").Cells(cont, 9) Like BUSQUEDAPARAIMPRESIÓN Then
If Sheets("HERMANDAD").Cells(cont, 10) Like BUSQUEDAPARAIMPRESIÓN Then
ID = Sheets("HERMANDAD").Cells(cont, 1)
NIT = Sheets("HERMANDAD").Cells(cont, 2)
RAZONSOCIAL = Sheets("HERMANDAD").Cells(cont, 3)
NOMBRES = Sheets("HERMANDAD").Cells(cont, 4)
APELLIDOS = Sheets("HERMANDAD").Cells(cont, 5)
DIRECCION = Sheets("HERMANDAD").Cells(cont, 6)
CONTACTO = Sheets("HERMANDAD").Cells(cont, 7)
TELEFONO1 = Sheets("HERMANDAD").Cells(cont, 8)
TELEFONO2 = Sheets("HERMANDAD").Cells(cont, 9)
DESCRIPCION = Sheets("HERMANDAD").Cells(cont, 10)
ultimaFilaAuxiliar = Sheets("Hoja1").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Hoja1").Cells(ultimaFilaAuxiliar + 1, 1) = ID
Sheets("Hoja1").Cells(ultimaFilaAuxiliar + 1, 2) = NIT
Sheets("Hoja1").Cells(ultimaFilaAuxiliar + 1, 3) = RAZONSOCIAL
Sheets("Hoja1").Cells(ultimaFilaAuxiliar + 1, 4) = NOMBRES
Sheets("Hoja1").Cells(ultimaFilaAuxiliar + 1, 5) = APELLIDOS
Sheets("Hoja1").Cells(ultimaFilaAuxiliar + 1, 6) = DIRECCION
Sheets("Hoja1").Cells(ultimaFilaAuxiliar + 1, 7) = CONTACTO
Sheets("Hoja1").Cells(ultimaFilaAuxiliar + 1, 8) = TELEFONO1
Sheets("Hoja1").Cells(ultimaFilaAuxiliar + 1, 9) = TELEFONO2
Sheets("Hoja1").Cells(ultimaFilaAuxiliar + 1, 10) = DESCRIPCION
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
Next cont
ultimaFilaAuxiliar = Sheets("Hoja1").Range("A" & Rows.Count).End(xlUp).Row
With Sheets("Hoja1").Range("A2:J" & ultimaFilaAuxiliar).Font
.Name = "Arial"
.Size = 9
.Italic = True
End With
MsgBox "Proceso terminado", vbInformation, "Resultado"
End Sub

Es con esto no se que ando haciendo mal, o 2 que me recomiendas es de una hoja a otra copiar y buscar

1

1 respuesta

Respuesta
1

Primero, debes cambiar esta variable

Busquedaparaimpresión

'

Por esta otra

PalabraBusqueda

'

Ahora, revisando tus If's anidados, ¿Más bien qué necesitas?

Quieres buscar la palabraBusqueda; ¿Y si aparece en cualquiera de las columnas de la A a la J quieres que pase los datos a la Hoja1?


Me comentas.

Lo que realmente quiero es que con la celda palabraBusqueda = Sheets("HERMANDAD").Cells(3, 16) con eso buscar pero quiero que realice una búsqueda por las 10 columnas para luego pasar toda la información de la palabra buscada osea que si esa palabra colocada ahí tiene más información de la a a la j en la fila se copie a la otra hoja

Ayuda por favor

Te anexo la macro actualizada

Sub Transferir_Datos_Otra_Hoja()
'Por Dante Amor
    Application.ScreenUpdating = False
    Set h1 = Sheets("HERMANDAD")
    Set h2 = Sheets("Hoja1")
    palabra = "*" & h1.Cells(3, "P") & "*"
    For i = 2 To h1.Range("A" & Rows.Count).End(xlUp).Row
        For j = 1 To 10
            If h1.Cells(i, j).Value Like palabra Then
                h1.Range("A" & i & ":J" & i).Copy
                u2 = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
                h2.Rows(u2).PasteSpecial xlValues
                Exit For
            End If
        Next
    Next
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "Proceso terminado", vbInformation, "Resultado"
End Sub

[sal u dos

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas