Copiar rangos discontinuos solo si cumple 2 condiciones
[ATTACH]40820.vB[/ATTACH][ATTACH]40821.vB[/ATTACH][ATTACH]40822.vB[/ATTACH]Buenas tardes mis estimados:
Edito mi mensaje porque creo que hice una historia, además de que solo me gustaría me orientaran,
Me podrían orientar si se puede copiar rangos discontinuos de la hoja1 (acumulado) a hoja2(reportes) y que cumplan dos condiciones:
1.- con un InputBox copiar solo lo que sean Elektra y
2.- si se puede otro InputBox y con ello elegir el año y solo copiar los registros de ese año, la fecha que tomo para hacer el filtro es del titulo “REG_fechahora”.
Mis títulos no son los mismos pero los relaciono en un archivo para no confundirlos. El archivo real es el del ejemplo, disculpen pero como edite mi mensaje tuve que subir otro archivo.
Gracias y cualquier comentario lo agradeceré muchísimo, Un saludo, yiyilans
Option Explicit Sub Elektra() Dim Celda As Range Dim Respuesta As Variant Application.Workbooks(1).Worksheets(2).Range("A1").Activate If Not IsEmpty(ActiveCell) Then GoTo Line1 Else GoTo Line2 Line1: Respuesta = MsgBox("Existen registros:" & Chr(13) & "¿Desea eliminarlos?", vbYesNo + vbQuestion, "Eliminar") If Respuesta = vbYes Then Range("A1:M50000").Select Selection.Clear Range("A1").Select Else: Exit Sub End If Line2: Respuesta = MsgBox("¿Desea ejecutar reporte?", vbYesNo + vbQuestion, "Reporte Elektra") If Respuesta = vbYes Then With ActiveSheet .Range("A1").Value = "Fecha atención" .Range("B1").Value = "Reporte" .Range("C1").Value = "Siniestro" .Range("D1").Value = "Poliza" .Range("E1").Value = "Nombre lesionado" .Range("F1").Value = "Cobertura" .Range("G1").Value = "Edad" .Range("H1").Value = "Sexo" .Range("I1").Value = "Instiución médica" .Range("J1").Value = "Diagnóstico inicial" .Range("K1").Value = "Tipo atención" With Range("A1:K1") .Font.ColorIndex = 29 .Interior.ColorIndex = 24 .Font.Bold = True .Font.Italic = True .Font.Name = "Calibri" .Font.Size = 11 End With For Each Celda In Range("A1:K1").Cells Celda.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium, ColorIndex:=RGB(0, 0, 0) Next Celda End With Else: Exit Sub End If End Sub[ATTACH]40820.vB[/ATTACH][ATTACH]40821.vB[/ATTACH][ATTACH]40822.vB[/ATTACH]
Copiar rangos discontinuos solo si cumple 2 condiciones
[ATTACH]40820.vB[/ATTACH][ATTACH]40821.vB[/ATTACH][ATTACH]40822.vB[/ATTACH]Buenas tardes mis estimados:
Edito mi mensaje porque creo que hice una historia, además de que solo me gustaría me orientaran,
Me podrían orientar si se puede copiar rangos discontinuos de la hoja1 (acumulado) a hoja2(reportes) y que cumplan dos condiciones:
1.- con un InputBox copiar solo lo que sean Elektra y
2.- si se puede otro InputBox y con ello elegir el año y solo copiar los registros de ese año, la fecha que tomo para hacer el filtro es del titulo “REG_fechahora”.
Mis títulos no son los mismos pero los relaciono en un archivo para no confundirlos. El archivo real es el del ejemplo, disculpen pero como edite mi mensaje tuve que subir otro archivo.
Gracias y cualquier comentario lo agradeceré muchísimo, Un saludo, yiyilans
Un saludo, yiyilans
Acumulado.zip
Reportes.zip
Titulos.xls
Ejemplo.zip