Filtro entre dos fechas (desde hasta)
Hola
Bien, la idea que con la macro que une las 4 listas se pueda realizar una búsqueda entre fechas.
Ahora habría que añadir una macro que realice la búsqueda entre fechas.
Esta es la macro que une las 4 listas y funciona perfecta.
Private Sub OptionButton1_Click()
'Por.Dante Amor
Dim fec1 As Date, fec2 As Date
Set hm = Sheets("datosm")
'
hm.Cells.Clear
Sheets("datos").Rows(1).Copy hm.Rows(1)
'
hs = Array("datos", "datos2", "datos3", "datos4")
For h = LBound(hs) To UBound(hs)
hoja = hs(h)
For i = 2 To Sheets(hoja).Range("A" & Rows.Count).End(xlUp).Row
If Sheets(hoja).Cells(i, "A") <> "" Then
u = hm.Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets(hoja).Rows(i).Copy hm.Rows(u)
End If
Next
Next
'
With hm.Cells
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
With hm.UsedRange
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With
'
u = hm.Range("A" & Rows.Count).End(xlUp).Row
With hm.Sort
.SortFields.Clear
.SortFields.Add Key:=hm.Range("A2:A" & u), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange hm.Range("A1:X" & u)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'mostramos el resultado del filtro avanzado en el textbox
ListBox1.RowSource = Empty
ListBox1.RowSource = hm.Name & "!A2:X" & u
End Sub
1 Respuesta
Te anexo la macro actualizada para filtrar por fecha
Private Sub CommandButton1_Click()
'Por.Dante Amor
Dim fec1 As Date, fec2 As Date
Set hm = Sheets("datosm")
'
hm.Cells.Clear
Sheets("datos").Rows(1).Copy hm.Rows(1)
'
fec1 = TextBox2
fec2 = TextBox3
hs = Array("datos", "datos2", "datos3", "datos4")
'
For h = LBound(hs) To UBound(hs)
hoja = hs(h)
For i = 2 To Sheets(hoja).Range("A" & Rows.Count).End(xlUp).Row
For j = Sheets(hoja).Columns("G").Column To Sheets(hoja).Columns("W").Column Step 2
If Sheets(hoja).Cells(i, j) >= fec1 And Sheets(hoja).Cells(i, j) <= fec2 Then
u = hm.Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets(hoja).Rows(i).Copy hm.Rows(u)
hm.Cells(u, j).Interior.ColorIndex = 4
End If
Next
Next
Next
'
With hm.Cells
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
With hm.UsedRange
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With
'
u = hm.Range("A" & Rows.Count).End(xlUp).Row
With hm.Sort
.SortFields.Clear
.SortFields.Add Key:=hm.Range("A2:A" & u), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange hm.Range("A1:X" & u)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'mostramos el resultado del filtro avanzado en el textbox
ListBox1.RowSource = Empty
ListBox1.RowSource = hm.Name & "!A2:X" & u
End SubSaludos.Dante Amor
