Ciclo para eliminar celdas con números

 

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

------------------

Crear Clase en Userform

 Código en el userform

---------------------

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

------------------------

Recomendación

Cargar ComboBox Mientras Escribes

 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

__________

OPTIMIZAR CODIGO

 Código:

-----

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

-----

Como editar los datos en un listbox

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

----------------

Carrito de compras

Simular carrito de compras con VBA Excel, utilizando un userform y listbox.

Filtrar registros de una base y cargarlos en un listbox, de ese listbox seleccionar registros y pasarlos a otro listbox (nuestro carrito de compras).

Código:

--------------------------------------------------------------

Option Explicit

Dim a As Variant

Private Sub CmbAutor_Change()

  Call FiltrarDatos

End Sub

Private Sub CmbIdioma_Change()

  Call FiltrarDatos

End Sub

Private Sub TextBox1_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

  

  Set dic = CreateObject("Scripting.Dictionary")

  For i = 0 To ListBox2.ListCount - 1

    dic(ListBox2.List(i, 0)) = Empty

  Next

  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 And _

      Not dic.exists(a(i, 1)) 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 MoverA_Click()

  Call Mover(ListBox1, ListBox2)

End Sub

--------------------------------------------------------------

-----------------------------------

Vídeos relacionados:

Manejo de matrices:

https://www.youtube.com/playlist?list=PLmz9wGL_ItXN2J8xrd2ZQIEww60nHj_Z_

Utilización de Dictionary:

https://www.youtube.com/playlist?list=PLmz9wGL_ItXMwyD1AN9s4VDBCJ5EPjR-F

Ejemplo carga de listbox con una matriz:

https://www.youtube.com/watch?v=Bn-xtarwrsk&list=PLmz9wGL_ItXM9bnmejwoaiewa4TiCveuC&index=3&t=4s

Ordenar datos en el combobox:

https://www.youtube.com/watch?v=4klJVh_Ob0M&list=PLmz9wGL_ItXM9bnmejwoaiewa4TiCveuC&index=7

Cargar en Listbox con Filtro Dinamico

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
__________________

Descarga el archivo:

Actualizar Estatus de Archivos

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

---