Necesito darle formato al resultado de Buscar
Hola diosa, necesito una ayuda por favor.
Mi problema es: Generé una macro que me busca en una base de datos y luego copia lo encontrado de la hoja1 en hoja2, que es lo que quería, pero necesito que cuando las copie en la hoja2, cada una de las filas sean pegadas con una fila en blanco entre ellas (es decir: una fila con información, luego una en blanco, una con inf. Y otra en blanco, etc).
Además, por favor,¿cómo puedo poner underline en estas filas en blanco pero solo en las columnas G y H según número de datos encontrados?
Te agradece de antemano
Sergio Pablo
Mi problema es: Generé una macro que me busca en una base de datos y luego copia lo encontrado de la hoja1 en hoja2, que es lo que quería, pero necesito que cuando las copie en la hoja2, cada una de las filas sean pegadas con una fila en blanco entre ellas (es decir: una fila con información, luego una en blanco, una con inf. Y otra en blanco, etc).
Además, por favor,¿cómo puedo poner underline en estas filas en blanco pero solo en las columnas G y H según número de datos encontrados?
Te agradece de antemano
Sergio Pablo
1 respuesta
Respuesta de Elsa Matilde
1
Si ya tenés una macro me la tenías que haber enviado para que trabaje sobre ella, es más fácil y seguro.
Debes leer y copiar de la hoja1 a la 2 utilizando un contador que incremente en 2, entonces podes tener bucle así:
Do
Sheets("Hoja1"). Cells(fila1, 1).Copy Destination:=Sheets("Hoja2"). Celss(fila2, 1)
fila1=fila1+1
fila2=fila2+2
Loop while cells(fila1,1)<> ""
Este ejemplo se repite hasta encontrar una celda vacía, pero eso es solo a fines del ejemplo.
La segunda parte de la consulta no la comprendí.
Espero tus comentarios y/o la finalización de la consulta
Saludos
Debes leer y copiar de la hoja1 a la 2 utilizando un contador que incremente en 2, entonces podes tener bucle así:
Do
Sheets("Hoja1"). Cells(fila1, 1).Copy Destination:=Sheets("Hoja2"). Celss(fila2, 1)
fila1=fila1+1
fila2=fila2+2
Loop while cells(fila1,1)<> ""
Este ejemplo se repite hasta encontrar una celda vacía, pero eso es solo a fines del ejemplo.
La segunda parte de la consulta no la comprendí.
Espero tus comentarios y/o la finalización de la consulta
Saludos
Hola diosa, tienes razón con el hecho de mejor mandarte la macro para que me ayudes, ya que no me resulto la solución entregada por ti.
Bueno, primero me voy a explicar bien. Lo que necesito es que en la hoja2 me entregue la información con el siguiente formato:
sergiopablo
______________
elsamatilde
______________
La gracia es que me entregue las líneas en las columnas G y H, pero solo en las filas en blanco, según la cantidad de datos encontrados(la idea es que sea una hoja de contrafirma).
La Macro es esta:
Option Explicit
' Numero de columnas(campos) de las que consta cada registro
Const Num_Columnas = 6
Private Sub Copiar_Datos_Click()
Dim r1 As Range, r2 As Range
Dim encontrado As Boolean
' Si el cuadro de texto está vacío, no se busca nada
If Len(Datos_Buscar.Value) = 0 Then
MsgBox ("No hay datos que buscar")
Else
' Borrar los datos actuales
Call borrar_datos
' Activar Casilla A11 de Hoja2 y referenciarla con r2, Es la casilla donde se copiarán
'los datos en caso que se encuentren
Worksheets(2).Range("A11").Activate
Set r2 = ActiveCell
' Activar casilla A2 de Hoja1 y referenciarla con r1
Worksheets(1).Activate
Worksheets(1).Range("A2").Activate
' Recorrer todo el rango de datos de Hoja1
encontrado = False
Do While Not IsEmpty(ActiveCell)
' Si la casilla activa = Datos_Buscados
If ActiveCell.Value = Datos_Buscar.Text Then
encontrado = True
' Referenciar con r1 la celda donde están os datos
Set r1 = ActiveCell
' Copiar los datos
Call Copiar_Datos_Hojas(r1, r2)
' Referenciar con r2 la casilla donde se copiaran los próximos datos
Set r2 = r2.Offset(1, 0)
End If
ActiveCell.Offset(1, 0).Activate
Loop
Worksheets(2).Activate
If encontrado Then
MsgBox ("Datos Copiados")
Else
MsgBox ("Ninguna coincidencia")
End If
End If
End Sub
' Procedimiento para borrar los datos de Hoja2 se llama antes de proceder a la nueva copia
Private Sub borrar_datos()
Dim i As Integer
Worksheets(2).Range("A11").Activate
Do While Not IsEmpty(ActiveCell)
For i = 0 To Num_Columnas - 1
ActiveCell.Offset(0, i).Value = ""
Next i
ActiveCell.Offset(1, 0).Activate
Loop
End Sub
' Procedimiento para copiar los datos de Hoja1 a Hoja2
' Parámetros.
' r1 = Celda Origen
' r2 = Celda Destino
Private Sub Copiar_Datos_Hojas(r1 As Range, r2 As Range)
Dim i As Integer
Dim Datos As Variant
' Recorrer las columnas del registro y copiar celda a celda
For i = 0 To Num_Columnas - 1
Datos = r1.Offset(0, i).Value
r2.Offset(0, i).Value = Datos
Next i
End Sub
Agradezco de antemano tu ayuda.
Bueno, primero me voy a explicar bien. Lo que necesito es que en la hoja2 me entregue la información con el siguiente formato:
sergiopablo
______________
elsamatilde
______________
La gracia es que me entregue las líneas en las columnas G y H, pero solo en las filas en blanco, según la cantidad de datos encontrados(la idea es que sea una hoja de contrafirma).
La Macro es esta:
Option Explicit
' Numero de columnas(campos) de las que consta cada registro
Const Num_Columnas = 6
Private Sub Copiar_Datos_Click()
Dim r1 As Range, r2 As Range
Dim encontrado As Boolean
' Si el cuadro de texto está vacío, no se busca nada
If Len(Datos_Buscar.Value) = 0 Then
MsgBox ("No hay datos que buscar")
Else
' Borrar los datos actuales
Call borrar_datos
' Activar Casilla A11 de Hoja2 y referenciarla con r2, Es la casilla donde se copiarán
'los datos en caso que se encuentren
Worksheets(2).Range("A11").Activate
Set r2 = ActiveCell
' Activar casilla A2 de Hoja1 y referenciarla con r1
Worksheets(1).Activate
Worksheets(1).Range("A2").Activate
' Recorrer todo el rango de datos de Hoja1
encontrado = False
Do While Not IsEmpty(ActiveCell)
' Si la casilla activa = Datos_Buscados
If ActiveCell.Value = Datos_Buscar.Text Then
encontrado = True
' Referenciar con r1 la celda donde están os datos
Set r1 = ActiveCell
' Copiar los datos
Call Copiar_Datos_Hojas(r1, r2)
' Referenciar con r2 la casilla donde se copiaran los próximos datos
Set r2 = r2.Offset(1, 0)
End If
ActiveCell.Offset(1, 0).Activate
Loop
Worksheets(2).Activate
If encontrado Then
MsgBox ("Datos Copiados")
Else
MsgBox ("Ninguna coincidencia")
End If
End If
End Sub
' Procedimiento para borrar los datos de Hoja2 se llama antes de proceder a la nueva copia
Private Sub borrar_datos()
Dim i As Integer
Worksheets(2).Range("A11").Activate
Do While Not IsEmpty(ActiveCell)
For i = 0 To Num_Columnas - 1
ActiveCell.Offset(0, i).Value = ""
Next i
ActiveCell.Offset(1, 0).Activate
Loop
End Sub
' Procedimiento para copiar los datos de Hoja1 a Hoja2
' Parámetros.
' r1 = Celda Origen
' r2 = Celda Destino
Private Sub Copiar_Datos_Hojas(r1 As Range, r2 As Range)
Dim i As Integer
Dim Datos As Variant
' Recorrer las columnas del registro y copiar celda a celda
For i = 0 To Num_Columnas - 1
Datos = r1.Offset(0, i).Value
r2.Offset(0, i).Value = Datos
Next i
End Sub
Agradezco de antemano tu ayuda.
Te adjunto la primer rutina con los ajustes que "creo" es lo que te falta. Además te agregué la rutina del underline que la colocarás en un módulo.
Tuve que modificar los Worksheets con el nombre de hoja para que me funcione, volvelos a su nombre original.
Private Sub Copiar_Datos_Click()
Dim r1 As Range, r2 As Range
Dim encontrado As Boolean
' Si el cuadro de texto está vacío, no se busca nada
If Len(Datos_Buscar.Value) = 0 Then
MsgBox ("No hay datos que buscar")
Else
' Borrar los datos actuales
Call borrar_datos
' Activar Casilla A11 de Hoja2 y referenciarla con r2, Es la casilla donde se copiarán
'los datos en caso que se encuentren
Worksheets("Hoja2").Range("A11").Select
Set r2 = ActiveCell
' Activar casilla A2 de Hoja1 y referenciarla con r1
Worksheets("Hoja1").Activate
Worksheets("Hoja1").Range("A2").Activate
' Recorrer todo el rango de datos de Hoja1
encontrado = False
Do While Not IsEmpty(ActiveCell)
' Si la casilla activa = Datos_Buscados
If ActiveCell.Value = Datos_Buscar.Text Then
encontrado = True
' Referenciar con r1 la celda donde están os datos
Set r1 = ActiveCell
' Copiar los datos
Call Copiar_Datos_Hojas(r1, r2)
' Referenciar con r2 la casilla donde se copiaran los próximos datos-
'AQUI COLOQUÉ LA INSTRUCCION NECESARIA PARA EL SUBRAYADO _
Y AJUSTE EL SALTO A 2 RENGLONES
Call underlinear(r2)
Set r2 = r2.Offset(2, 0)
End If
ActiveCell.Offset(1, 0).Activate
Loop
Worksheets("Hoja2").Activate
If encontrado Then
MsgBox ("Datos Copiados")
Else
MsgBox ("Ninguna coincidencia")
End If
End If
End Sub
Sub underlinear(r2 As Range)
r2.Offset(1, 6).Font.Underline = xlUnderlineStyleSingle
r2.Offset(1, 7).Font.Underline = xlUnderlineStyleSingle
r2.Offset(1, 6).FormulaR1C1 = "'-------------------"
r2.Offset(1, 7).FormulaR1C1 = "'-------------------"
'utilicé unos guiones porque sino no se ve el subrayado
End Sub
Saludos
Elsa
(Si no te devuelve como lo estás pensando, enviame un libro con una muestra a mi correo)
Tuve que modificar los Worksheets con el nombre de hoja para que me funcione, volvelos a su nombre original.
Private Sub Copiar_Datos_Click()
Dim r1 As Range, r2 As Range
Dim encontrado As Boolean
' Si el cuadro de texto está vacío, no se busca nada
If Len(Datos_Buscar.Value) = 0 Then
MsgBox ("No hay datos que buscar")
Else
' Borrar los datos actuales
Call borrar_datos
' Activar Casilla A11 de Hoja2 y referenciarla con r2, Es la casilla donde se copiarán
'los datos en caso que se encuentren
Worksheets("Hoja2").Range("A11").Select
Set r2 = ActiveCell
' Activar casilla A2 de Hoja1 y referenciarla con r1
Worksheets("Hoja1").Activate
Worksheets("Hoja1").Range("A2").Activate
' Recorrer todo el rango de datos de Hoja1
encontrado = False
Do While Not IsEmpty(ActiveCell)
' Si la casilla activa = Datos_Buscados
If ActiveCell.Value = Datos_Buscar.Text Then
encontrado = True
' Referenciar con r1 la celda donde están os datos
Set r1 = ActiveCell
' Copiar los datos
Call Copiar_Datos_Hojas(r1, r2)
' Referenciar con r2 la casilla donde se copiaran los próximos datos-
'AQUI COLOQUÉ LA INSTRUCCION NECESARIA PARA EL SUBRAYADO _
Y AJUSTE EL SALTO A 2 RENGLONES
Call underlinear(r2)
Set r2 = r2.Offset(2, 0)
End If
ActiveCell.Offset(1, 0).Activate
Loop
Worksheets("Hoja2").Activate
If encontrado Then
MsgBox ("Datos Copiados")
Else
MsgBox ("Ninguna coincidencia")
End If
End If
End Sub
Sub underlinear(r2 As Range)
r2.Offset(1, 6).Font.Underline = xlUnderlineStyleSingle
r2.Offset(1, 7).Font.Underline = xlUnderlineStyleSingle
r2.Offset(1, 6).FormulaR1C1 = "'-------------------"
r2.Offset(1, 7).FormulaR1C1 = "'-------------------"
'utilicé unos guiones porque sino no se ve el subrayado
End Sub
Saludos
Elsa
(Si no te devuelve como lo estás pensando, enviame un libro con una muestra a mi correo)
