Macro para filtrar por rango de fecha
Para Dante Amor:
Estimado quisiera tu soporte para poder filtrar por rango fecha con la macro con unos DtPicker que anteriormente conté con tu ayuda.
La idea es seleccionar rango fechas por cliente y tenga los valores en el formulario.
A la espera de tu acostumbrado apoyo.
1 Respuesta
Respuesta de Dante Amor
1
H o l a:
Te anexo la macro para filtrar por fechas
Dim h As Object, ht As Object
'
Private Sub CommandButton4_Click()
'Por.Dante Amor
TextBox1 = ""
TextBox2 = ""
If ComboBox1 = "" Then
MsgBox "Selecciona el cliente"
ComboBox1.SetFocus
Exit Sub
End If
'
u = h.Range("H" & Rows.Count).End(xlUp).Row
ht.Cells.Clear
'Encabezados para el filtro
ht.[C1] = h.[h1]
ht.[D1] = h.[A1]
ht.[E1] = h.[A1]
ht.[F1] = h.[G1]
'
'Valores para el filtro
ht.[A2] = DTPicker1
ht.[B2] = DTPicker2
ht.[C2] = ComboBox1
ht.[D2] = IIf(CheckBox1, "="">=""&RC[-3]", "")
ht.[E2] = IIf(CheckBox1, "=""<=""&RC[-3]", "")
'
'Filtrar
h.Range("A1:J" & u).AdvancedFilter xlFilterCopy, ht.[C1:F2], ht.[G1]
'Calcular
m3 = WorksheetFunction.Sum(ht.Range("P2:P" & u))
TextBox1 = Format(m3, "#,##0.000")
ud = WorksheetFunction.Sum(ht.Range("L2:L" & u))
TextBox2 = Format(ud, "#,##0.00")
End Sub
'
Private Sub UserForm_Activate()
'Por.Dante Amor
Set h = Sheets("Ruteos 2015")
Set ht = Sheets("tmp")
h.Columns("H").Copy Sheets("tmp").[A1]
u = ht.Range("A" & Rows.Count).End(xlUp).Row
ht.Range("A1:A" & u).RemoveDuplicates Columns:=1, Header:=xlYes
With ht.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A2:A" & u): .Header = xlNo: .MatchCase = False
.Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
End With
'
For i = 2 To ht.Range("A" & Rows.Count).End(xlUp).Row
ComboBox1.AddItem ht.Cells(i, "A")
Next
'
ComboBox2.AddItem "SMENOR"
ComboBox2.AddItem "SMAYOR"
End Sub
'
Private Sub CommandButton3_Click()
Unload Me
End Sub
'
Private Sub ComboBox1_Change()
limpiar
End Sub
'
Private Sub CheckBox1_Click()
limpiar
End Sub
Private Sub DTPicker2_Change()
limpiar
End Sub
Private Sub DTPicker1_Change()
limpiar
End Sub
Sub limpiar()
TextBox1 = ""
TextBox2 = ""
End Sub':) ':)
