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 respuesta
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
