Jump to content

Copiar rangos con InputBox


Recommended Posts

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]

Un saludo, yiyilans

Acumulado.zip

Reportes.zip

Titulos.xls

Ejemplo.zip

Link to comment
Share on other sites

Archived

This topic is now archived and is closed to further replies.

×
×
  • Create New...

Important Information

Privacy Policy