Pasar datos desde un listbox a un nuevo libro
Dante, buenas noches.
He visto un código tuyo o mejor, que corregiste de otro usuario.
Respecto de ese me gustaría que me dijeras como filtrar entre rango de fechas en el textbox asociado al combobox de filtro y luego de que los datos se pasen al listbox desde un boton crear otro libro con todos los datos de este listbox.
Te recuerdo el código:
Private Sub UserForm_Initialize()
'
'For i = 1 To 31
'Me.Controls("Label" & i) = Cells(1, i).Value
'Next i
'
[A1].Select
With Me
.ListBox1.ColumnHeads = True
.ListBox1.ColumnCount = 31
.ListBox1.ColumnWidths = "60 pt;60 pt;60 pt;60 pt;60 pt;60 pt;60 pt;60 pt;60 pt;60 pt;60 pt;60 pt;60 pt;60 pt;60 pt;60 pt;60 pt;60 pt;60 pt;60 pt;60 pt;60 pt;60 pt;60 pt;60 pt;60 pt;60 pt;60 pt;60 pt;60 pt;60 pt"
.cmbEncabezado.List = Application.Transpose(ActiveCell.CurrentRegion.Resize(1).Value)
.cmbEncabezado.ListStyle = fmListStyleOption
End With
End Sub
Private Sub CommandButton5_Click()
'Act.Por.Dante Amor
Set h1 = Sheets("Hoja1")
Set h2 = Sheets("Temporal")
'
If Me.txtFiltro1.Value = "" Then Exit Sub
If cmbEncabezado = "" Then Exit Sub
'
h2.Cells.Clear
ListBox1.RowSource = ""
h1.Rows(1).Copy h2.Rows(1)
'
j = cmbEncabezado.ListIndex + 1
n = 2
'
For i = 2 To Range("a1").CurrentRegion.Rows.Count
If LCase(Cells(i, j)) Like "*" & LCase(txtFiltro1) & "*" Then
h1.Rows(i).Copy h2.Rows(n)
n = n + 1
End If
Next i
u = Range("A" & Rows.Count).End(xlUp).Row
If u = 1 Then
MsgBox "No existen registros con ese filtro", vbExclamation, "FILTRO"
Exit Sub
End If
ListBox1.RowSource = h2.Name & "!A2:Z" & u
End Sub
1 Respuesta
Para filtrar entre un rango de fechas necesitas 2 textbox para que puedas poner la fecha desde y la fecha hasta.
Envíame tu archivo con el userform y me explicas en dónde quieres el filtro
Mi correo [email protected]
En el asunto del correo escribe tu nombre de usuario “nachopulos”
¡Gracias! Gracias Dante, genio. Te envío el proyecto al correo.
Te anexo el código
'
Private Sub CommandButton5_Click()
'Por.Dante Amor
Set h1 = Sheets("Hoja1")
Set h2 = Sheets("Temporal")
'
h2.Cells.Clear
ListBox1.RowSource = ""
'
If cmbEncabezado = "" Or cmbEncabezado.ListIndex = -1 Then
MsgBox "Selecciona un filtro"
cmbEncabezado.SetFocus
Exit Sub
End If
If Me.txtFiltro1.Value = "" Then
MsgBox "Captura un dato"
txtFiltro1.SetFocus
Exit Sub
End If
'valida si se va a filtrar por fecha
h1.Rows(1).Copy h2.Rows(1)
uc = h2.Cells(1, Columns.Count).End(xlToLeft).Column
'
j = cmbEncabezado.ListIndex + 1
'
enc1 = h1.Cells(1, j)
h2.Cells(1, uc + 2) = enc1
h2.Cells(2, uc + 2).Value = "*" & txtFiltro1.Value & "*" 'pone el dato a filtrar
nc = 2 'columna siguiente
'
If cmbEncabezado.ListIndex = 1 Then
If Me.TextBox2.Value = "" Then
MsgBox "Captura fecha hasta"
TextBox2.SetFocus
Exit Sub
End If
If Not IsDate(Me.txtFiltro1.Value) Then
MsgBox "Captura fecha Desde válida"
txtFiltro1.SetFocus
Exit Sub
End If
If Not IsDate(Me.TextBox2.Value) Then
MsgBox "Captura fecha Hasta válida"
TextBox2.SetFocus
Exit Sub
End If
fec1 = CDate(txtFiltro1.Value)
fec2 = CDate(TextBox2.Value)
If fec2 < fec1 Then
MsgBox "La fecha Hasta no puede ser menor a la fecha Desde"
TextBox2.SetFocus
Exit Sub
End If
enc2 = h1.Cells(1, j)
h2.Cells(1, uc + 3) = enc2
h2.Cells(1, uc + 4) = fec1
h2.Cells(1, uc + 5) = fec2
h2.Cells(2, uc + 2).FormulaR1C1 = "="">=""&R[-1]C[2]" 'pone fecha desde
h2.Cells(2, uc + 3).FormulaR1C1 = "=""<=""&R[-1]C[2]" 'pone fecha hasta
nc = 3 'ajusta la columna para el filtro avanzando
End If
'
u1 = h1.Range("A" & Rows.Count).End(xlUp).Row
h1.Range(h1.Cells(1, "A"), h1.Cells(u1, uc)).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=h2.Range(h2.Cells(1, uc + 2), h2.Cells(2, uc + nc)), _
CopyToRange:=h2.Range(h2.Cells(1, "A"), h2.Cells(1, uc)), Unique:=False
'
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row
If u2 = 1 Then
MsgBox "No existen registros con ese filtro", vbExclamation, "FILTRO"
Exit Sub
End If
rango = Range(Cells(2, "A"), Cells(u2, uc)).Address
h2.Cells.EntireColumn.AutoFit
ancho = ""
For i = 1 To uc
ancho = ancho & Int(h2.Cells(1, i).Width) + 3 & ";"
Next
'
ListBox1.RowSource = h2.Name & "!" & rango
ListBox1.ColumnCount = uc
ListBox1.ColumnHeads = True
ListBox1.ColumnWidths = ancho
End Subsal u dos
