Macro para eliminar números y texto en mayúsculas de una columna
De la columna Q eliminar las celdas que contengan números y las celdas que contengan todo el texto en mayúsculas.
-------------------
Sub eliminar_numeros_texto_mayusculas() Dim a As Variant Dim i As Long, j As Long, k As Long, lr As Long Dim rng As Range Dim encontrado As Boolean Dim caracter As String
lr = Range("Q" & Rows.Count).End(3).Row a = Range("Q1:Q" & lr).Value Set rng = Range("Q" & lr + 1)
For i = 1 To UBound(a)
encontrado = False For k = 0 To 9 If InStr(1, a(i, 1), k) > 0 Then 'Encontró un número, entonces elimina la celda Set rng = Union(rng, Range("Q" & i)) encontrado = True Exit For End If Next
If encontrado = False Then For k = 97 To 122 caracter = Chr(k) If InStr(1, a(i, 1), Chr(k)) > 0 Then 'si existe una minúscula, entonces no elimina la celda encontrado = True Exit For End If Next
If encontrado = False Then 'si es falso, entonces son puras mayúculas, entonces elimina la celda Set rng = Union(rng, Range("Q" & i)) End If End If Next
'elimina las encontradas rng.ClearContents End Sub
Dim Lbl() As New Class1 'Al inicio de todo el código Private Sub UserForm_Initialize() Dim i As Long, ctrl As MSForms.Control i = 1 For Each ctrl In Me.Controls If TypeName(ctrl) = "Label" Then ReDim Preserve Lbl(i) Set Lbl(i).MultiLabel = ctrl i = i + 1 End If Next End Sub
------------------
Código en la clase:
--------------------------
Public WithEvents MultiLabel As MSForms.Label Private Sub MultiLabel_Click() With MultiLabel If .Caption = "" Then .Caption = "X" Else .Caption = "" End If End With End Sub
Filtrar los datos del combobox mientras escribes y desplegar las coincidencias:
Código:
__________
Option Explicit
Dim a As Variant, b As Variant
Private Sub ComboBox1_Change() Dim precio As Double With ComboBox1 .List = Filter(Application.Transpose(a), .Text, True, vbTextCompare) .DropDown TextBox1.Value = "" If .ListIndex > -1 Then precio = Sheets("Hoja1").Range("A:A").Find(.Value, , xlValues, xlWhole).Offset(, 1) TextBox1.Value = Format(precio, "$ #,###.##") End If End With End Sub
Private Sub UserForm_Activate() a = Sheets("Hoja1").Range("A2", Sheets("Hoja1").Range("A" & Rows.Count).End(3)).Value ComboBox1.List = a End Sub
Sub validar_datos(tb1 As MSForms.TextBox, tb2 As MSForms.TextBox, _ tb3 As MSForms.TextBox, tb4 As MSForms.TextBox, _ sht As String, cel As String, lna As String, _ tx1 As String, tx1a As String, tx2 As String, tx2a As String) Dim rng As Range Set rng = Sheets(sht).Range(cel) ' If tb1 < > Empty And tb2 = "" Then MsgBox "Falta la fecha del folio 1 en la linea " & lna, vbExclamation, "Falta Fecha" tb2.SetFocus ElseIf tb1 < > Empty And tb2 < > Empty And tb3 = "" Then rng.Value = tx1 & tb1 & tx1a & tb2 ElseIf tb1 < > Empty And tb2 < > Empty And tb3 < > Empty And tb4 = "" Then MsgBox "Falta la fecha del folio 2 en la linea " & lna, vbExclamation, "Falta Fecha" tb4.SetFocus ElseIf tb1 < > Empty And tb2 < > Empty And tb3 < > Empty And tb4 < > Empty Then rng.Value = tx2 & tb1 & ", " & tb3 & tx2a & tb2 & ", " & tb4 Else ' End If End Sub ' Private Sub CommandButton1_Click() Call validar_datos(TextBox1, TextBox2, TextBox3, TextBox4, "FORMATO", "F18", "1", _ texto1, texto1a, texto2, texto2a) ' Call validar_datos(TextBox5, TextBox6, TextBox7, TextBox8, "FORMATO", "F19", "2", _ texto3, texto3a, texto4, texto4a) ' Call validar_datos(TextBox9, TextBox10, TextBox11, TextBox12, "FORMATO", "F20", "3", _ texto5, texto5a, texto6, texto6a) ' ' 'repetir las 15 veces... ' End Sub
Editar los datos en un Listbox, cuando se encuentran filtrados. Modificar los datos, actualizar la hoja y actualizar el listbox.
Código VBA:
------------------
Option Explicit Dim a As Variant Dim sh As Worksheet Private Sub Actualizar_Click() Dim fila As Long
If ListBox1.ListIndex = -1 Then MsgBox "Seleccionar un título" Exit Sub End If
fila = ListBox1.List(ListBox1.ListIndex, 4) sh.Range("A" & fila).Value = TextBox2.Value sh.Range("D" & fila).Value = TextBox3.Value Call cargar_matriz Call FiltrarDatos End Sub Private Sub ListBox1_Click() TextBox2.Value = ListBox1.List(ListBox1.ListIndex, 0) TextBox3.Value = ListBox1.List(ListBox1.ListIndex, 3) Label6.Caption = ListBox1.List(ListBox1.ListIndex, 4) End Sub Private Sub TextBox1_Change() Call FiltrarDatos End Sub Private Sub CmbAutor_Change() Call FiltrarDatos End Sub Private Sub CmbIdioma_Change() Call FiltrarDatos End Sub Sub FiltrarDatos() Dim b As Variant Dim i As Long, j As Long, k As Long Dim dic As Object
ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2)) ListBox1.Clear
For i = 1 To UBound(a) If LCase(a(i, 1)) Like "*" & LCase(TextBox1) & "*" And _ a(i, 2) Like "*" & CmbAutor.Value And _ a(i, 3) Like "*" & CmbIdioma.Value Then k = k + 1 For j = 1 To UBound(a, 2) b(k, j) = a(i, j) Next End If Next ListBox1.List = b End Sub Private Sub UserForm_Activate() Me.Top = Range("A10").Top Me.Left = Range("B10").Left - 12 End Sub Private Sub UserForm_Initialize() Dim c As Range Dim dic As Object
Set sh = Sheets("Libros") Set dic = CreateObject("Scripting.Dictionary")
For Each c In sh.Range("B2", sh.Range("B" & Rows.Count).End(3)) dic(c.Value) = Empty Next CmbAutor.List = Application.Transpose(dic.keys)
dic.RemoveAll For Each c In sh.Range("C2", sh.Range("C" & Rows.Count).End(3)) dic(c.Value) = Empty Next CmbIdioma.List = Application.Transpose(dic.keys)
Call cargar_matriz End Sub Sub cargar_matriz() Dim i As Long
a = sh.Range("A2:E" & sh.Range("A" & Rows.Count).End(3).Row).Value For i = 1 To UBound(a) a(i, 5) = i + 1 Next ListBox1.List = a End Sub
Cómo cargar datos en el listbox de manera dinámica aplicando un filtro de lo que vas capturando en un textbox o en 2 textbox.
También en el vídeo muestro como ajustar el ancho de columna, formatear una fecha, formatear importes y también alinear los importes a la derecha.
______________
Option Explicit
Dim a As Variant
Dim sh As Worksheet
Private Sub UserForm_Activate()
Dim b As Variant
Dim cWidth As String
Dim i As Long, j As Long, n As Long
Dim importe As String
Set sh = Worksheets("Datos1")
a = sh.Range("A1:H" & sh.Range("A" & Rows.Count).End(xlUp).Row).Value2
ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
With ListBox1
.ColumnCount = UBound(a, 2)
'Ajustar ancho de columnas
sh.Range("A1", sh.Cells(1, UBound(a, 2))).EntireColumn.AutoFit
For i = 1 To UBound(a, 2)
If i > 5 Then n = 15
cWidth = cWidth & Int(sh.Cells(1, i).Width) + n & "; "
Next
.ColumnWidths = cWidth
.Font.Name = "Consolas"
.Font.Size = 10
'Formato de columnas
For i = 1 To UBound(a, 1)
For j = 1 To UBound(a, 2)
Select Case j
Case 1 To 4
b(i, j) = a(i, j)
Case 5
b(i, j) = Format(a(i, j), "dd/mm/yyyy")
Case 6, 7, 8
importe = Format(a(i, j), "#,##0.00")
b(i, j) = String(9 - Len(importe), " ") & importe
End Select
Next
Next
.List = b
End With
End Sub
Sub Filter_Data()
Dim i As Long, j As Long, k As Long
Dim txt1 As String, txt2 As String, importe As String
Dim b As Variant
ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
'Agregar títulos
For j = 1 To UBound(b, 2)
b(1, j) = a(1, j)
Next
k = 1
For i = 2 To UBound(a, 1)
If TextBox1.Text = "" Then txt1 = a(i, 1) Else txt1 = TextBox1.Text 'textbox1 busca en A
If TextBox2.Text = "" Then txt2 = a(i, 2) Else txt2 = TextBox2.Text 'textbox2 busca en B
If LCase(a(i, 1)) Like "*" & LCase(txt1) & "*" And _
LCase(a(i, 2)) Like "*" & LCase(txt2) & "*" Then
k = k + 1
For j = 1 To UBound(a, 2)
Select Case j
Case 1 To 4
b(k, j) = a(i, j)
Case 5
b(k, j) = Format(a(i, j), "dd/mm/yyyy")
Case 6, 7, 8
importe = Format(a(i, j), "#,##0.00")
b(k, j) = String(9 - Len(importe), " ") & importe
End Select
Next
End If
Next
ListBox1.List = b
End Sub
Private Sub TextBox1_Change()
Call Filter_Data
End Sub
Private Sub TextBox2_Change()
Call Filter_Data
End Sub __________________
Te muestro una aplicación para seleccionar tus archivos, poner un estatus y actualizar en automático los nombres de los archivos en la hoja con el estatus que escribiste.
Código:
Private Sub CommandButton1_Click() 'Por Dante Amor Dim sPath As String Dim sArch As Variant With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Selecciona la carpeta" If .Show <> -1 Then Exit Sub .InitialFileName = "C:\trabajo" sPath = .SelectedItems(1) & "\" End With sArch = Dir(sPath & "*.pdf") Do While sArch <> "" ListBox1.AddItem sPath & sArch sArch = Dir() Loop End Sub
Private Sub CommandButton2_Click() 'Por Dante Amor Dim i As Long, lr As Long, nmax As Long Dim inicial As Boolean ' If TextBox1.Value = "" Then MsgBox "Capturar el estatus", vbExclamation, "Excel y Macros" TextBox1.SetFocus Exit Sub End If If ListBox1.ListCount = 0 Then MsgBox "Seleccionar Carpeta", vbExclamation, "Excel y Macros" TextBox1.SetFocus Exit Sub End If lr = Range("A" & Rows.Count).End(3).Row + 1 nmax = WorksheetFunction.Max(Range("A2:A" & lr)) + 1 For i = 0 To ListBox1.ListCount - 1 If ListBox1.Selected(i) Then Range("A" & lr).Value = nmax Range("B" & lr).Value = ListBox1.List(i) Range("C" & lr).Value = TextBox1.Value lr = lr + 1 nmax = nmax + 1 inicial = True End If Next Application.ScreenUpdating = True If inicial = False Then MsgBox "No se seleccionaron archivos", vbExclamation, "Excel y Macros" Else MsgBox "Estatus actualizado", vbInformation, "Excel y Macros" ListBox1.Clear TextBox1.Value = "" Unload Me End If End Sub
Private Sub UserForm_Activate() ListBox1.MultiSelect = fmMultiSelectMulti ListBox1.ListStyle = fmListStyleOption End Sub