Copiar rangos con InputBox

yiyilans · el 3 de agosto

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]

[/PHP]