Mostrando las entradas con la etiqueta Inicio. Mostrar todas las entradas

Ciclos: For ... Next, Do ... Loop While, For Each ... Next

Aprende con los siguientes ejemplos a utilizar los ciclos:

For ... Next Do ... Loop While For Each ... Next

Código 1:

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

Sub ciclo_For()
Dim i As Long

For i = 1 To Range("A" & Rows.Count).End(3).Row
If Range("A" & i).Value = "SUMA" Then
Rows(i).Copy Sheets("Hoja2").Range("A" & Rows.Count).End(3)(2)
End If
Next
End Sub

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

Código 2:

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

Sub Ciclo_While()
Dim f As Range
Dim celda As String

Set f = Range("A:A").Find("SUMA", , xlValues, xlWhole)
If Not f Is Nothing Then
celda = f.Address
Do
Rows(f.Row).Copy Sheets("Hoja2").Range("A" & Rows.Count).End(3)(2)
Set f = Range("A:A").FindNext(f)
Loop While celda <> f.Address
End If
End Sub

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

Código 3:

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

Sub Ciclo_For_Each()
Dim ar As Range

For Each ar In Range("A1", Range("A" & Rows.Count).End(3)).SpecialCells(xlCellTypeConstants).Areas
Rows(ar.Cells(ar.Rows.Count).Row).Copy Sheets("Hoja2").Range("A" & Rows.Count).End(3)(2)
Next
End Sub

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

Mostrar imagen

Pon el siguiente código en los eventos de tu hoja, para mostrar una imagen al cambiar un dato en la celda D2

-----

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Address = "$D$3" Then
ActiveSheet.DrawingObjects("Rectángulo 1").Visible = Target.Value = "hola"
End If
End Sub

-----

Para devolver la última fila del rango de celdas seleccionadas:

-----

Sub seleccionar_ultimacelda()
Dim i&, f&, fila&
i = Selection.Cells(1).Row
f = Selection.Rows.Count
fila = i + f - 1
End Sub

-----

Comparar Celdas

La siguiente macro compara celdas utilizando dos ciclos, un ciclo para las filas y otro ciclo para las columnas.

Macro:

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

Sub compararceldas()
'Por Dante Amor
Dim i As Long, j As Long

For i = 5 To Range("F" & Rows.Count).End(3).Row
For j = 6 To 10
If Cells(i, j) <> "no vengo" Then
Cells(i, j) = "clásico"
End If
If Cells(i, j + 5) <> "no vengo" Then
Cells(i, j + 5) = "postre"
End If
Next
Next
End Sub

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

Macro para borrar rangos de celdas

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

Sub borrar_rangos()
'Por Dante Amor
Dim i As Long, j As Long
Dim rng As Range

For i = 2 To 120 Step 7
For j = 1 To Columns("E").Column Step 2
If rng Is Nothing Then
Set rng = Cells(i, j).Resize(3)
Else
Set rng = Union(rng, Cells(i, j).Resize(3))
End If
Next
Next
rng.ClearContents
End Sub

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

Macro para hacer suma y eliminar columnas:

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

Sub suma_columnas()
Dim i As Long, j As Long
Dim f As Range

Application.ScreenUpdating = False
Set f = Range("A:Y").Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
If Not f Is Nothing Then
i = f.Row + 1
With Range("A" & i).Resize(1, 25)
.Formula = "=SUM(A1:A" & i - 1 & ")"
.Value = .Value
End With
For j = 25 To 1 Step -1
If Cells(i, j).Value = 0 Then
Columns(j).EntireColumn.Delete
End If
Next
End If
Application.ScreenUpdating = True
End Sub

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

Código en el UserForm para activar el OptionButton

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

Private Sub ListBox1_Click()
If ListBox1.List(ListBox1.ListIndex, 4) = "Ingresos" Then
OptionButton1.Value = True
Else
OptionButton2.Value = True
End If
End Sub

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

Consejos para empezar a programar macros:

Saludos

Dante Amor

Mostrar imagen al pasar el mouse por una celda

Utiliza la siguiente macro para mostrar una imagen en la hoja con simplemente pasar el mouse por la celda que contiene la fórmula:

=SI.ERROR(HIPERVINCULO(MiEvento(FILA(),COLUMNA()),"Ver imagen"),"Ver imagen")

Inserta el siguiente código en un módulo:

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

Public Function MiEvento(fila As Long, columna As Long)

Dim imagen As Object

Dim nombre As String, carpeta As String

Dim celda As Range

Dim pict As Object

carpeta = "C:\trabajo\imagenes\" 'Carpeta con los archivos

Set celda = Range("A" & fila) 'Columna con el nombre de los archivos

nombre = celda.Text

On Error Resume Next

Set imagen = ActiveSheet.Pictures(celda.Text)

For Each pict In ActiveSheet.Pictures

If pict.Name <> nombre Then

pict.Delete

End If

On Error GoTo 0

If imagen Is Nothing Then

Set imagen = ActiveSheet.Pictures.Insert(carpeta & nombre & ".JPG") 'Extensión del archivo

With imagen

.Name = nombre

.Top = celda.Top

.Left = Cells(fila, columna + 1).Left + 10

.ShapeRange.LockAspectRatio = msoFalse

.ShapeRange.Height = 105 'Alto de la imagen

.ShapeRange.Width = 75 'Ancho de la imagen

End With

End If

End Function

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

Consulta el procedimiento en el vídeo:

Saludos

Dante Amor

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

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

Ciclo For Para Poner Días

Generar días del mes cada tres renglones poner el siguiente día.

Generar los días del mes dejar tres renglones y en cuarto poner el día del mes en una hoja de excel

Por ejemplo:

Fila uno: miércoles 1 de noviembre de 2023

Fila dos.

Fila tres

Fila cuatro

Fila cinco: jueves 2 de noviembre del 2023

Macro:

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

Sub ponerdias()
Dim dia As Long, finmes As Long, n As Long

n = 1
finmes = Day(WorksheetFunction.EoMonth(Date, 0))
For dia = 1 To finmes
Range("A" & n).Value = DateSerial(Year(Date), Month(Date), dia)
n = n + 4
Next
End Sub

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

Para cualquier mes, cambia "dic" por el mes que necesitas

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

Sub ponerdias()
Dim dia As Long, finmes As Long, n As Long
Dim fecha As Date

fecha = CDate("01/dic/2023")
n = 1
finmes = Day(WorksheetFunction.EoMonth(fecha, 0))
For dia = 1 To finmes
Range("A" & n).Value = DateSerial(Year(fecha), Month(fecha), dia)
n = n + 4
Next
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

-----

Enviar correos con condición

Tienes una lista de registros y quieres enviarle un correo a cada destinatario dependiendo de una condición.

Código VBA:

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

Sub Enviar_Correos()

'Por.Dante Amor

Dim i As Long

Dim dam As Object

For i = 2 To Range("A" & Rows.Count).End(xlUp).Row

If Range("E" & i).Value = "Pendiente" Then

Set dam = CreateObject("outlook.application").createitem(0)

dam.To = Range("B" & i).Value 'Destinatarios

dam.Subject = "Pendientes"

dam.Body = "Buen día : " & Range("A" & i).Value & vbCr & _

"Tiene pendiente el siguiente: " & Range("C" & i).Value

dam.Display 'El correo se muestra

End If

MsgBox "Correos enviados"

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

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

Enviar correos masivos

Con esta herramienta podrás listar en una hoja de Excel todos los correos que deseas enviar, a cada destinatario o destinatarios un asunto de correo diferente, a cada destinatario enviar uno o varios archivos, incluso podrás poner con copia a destinatarios diferentes y con copia oculta a otros destinatarios.

Puedes enviar varios archivos a varios correos o un solo archivo en varios correos a varios destinatarios.

Código en los eventos de la hoja:

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

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
Dim rng As Range, t As Range

Set rng = Intersect(Target, Range("B2:B" & Rows.Count))
If Not rng Is Nothing Then
For Each t In Target
If t.Value <> "" Then
ActiveSheet.Hyperlinks.Add _
Anchor:=Cells(t.Row, "G"), Address:="", _
SubAddress:=ActiveSheet.Name & "!C" & t.Row, _
TextToDisplay:="Insertar archivo"
End If
Next
Cells(Target.Row, 3).Select
End If
End Sub
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
'Por.Dante Amor
Dim linea As Long, col As Long
Dim archivo As Variant

linea = ActiveCell.Row
col = Cells(linea, Columns.Count).End(xlToLeft).Column + 1
If col < 8 Then col = 8
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Seleccione uno o varios archivos"
.Filters.Clear
.Filters.Add "archivos pdf", "*.pdf*"
.Filters.Add "archivos de excel", "*.xls*"
.Filters.Add "Todos los archivos", "*.*"
.FilterIndex = 1
.AllowMultiSelect = True
.InitialFileName = "c:\trabajo\pdfs"
If .Show Then
For Each archivo In .SelectedItems
Cells(linea, col) = archivo
col = col + 1
Next
End If
End With
End Sub

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

Código en un módulo:

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

Option Explicit
Sub Enviar_Correos()
'Por.Dante Amor
'***Macro Para enviar correos masivos
Dim i As Long, j As Long
Dim dam As Object
Dim archivo As String

For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
Set dam = CreateObject("Outlook.Application").CreateItem(0)
'
dam.To = Range("B" & i).Value 'Destinatarios
dam.Cc = Range("C" & i).Value 'Con copia
dam.Bcc = Range("D" & i).Value 'Con copia oculta
dam.Subject = Range("E" & i).Value 'Asunto
dam.Body = Range("F" & i).Value 'Cuerpo del mensaje
'
For j = Range("H1").Column To Cells(i, Columns.Count).End(xlToLeft).Column
archivo = Cells(i, j).Value
If archivo <> "" Then dam.Attachments.Add archivo
Next
dam.Send 'El correo se envía en automático
'dam.Display 'El correo se muestra
Next
MsgBox "Correos enviados", vbInformation, "SALUDOS"
End Sub

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

Descargar el archivo:

https://drive.google.com/file/d/11HQqHfRsOaI4GO64brudbuK8x4K3rmEF/view?usp=sharing

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

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

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)

End If

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

Poner negritas

La siguiente macro la puedes utilizar para poner en negritas parte del texto de una celda de Excel.

Utilizando una macro recorrer todas las filas y poner en negritas el texto de la derecha de cada celda.

Macro:

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

Option Explicit
Sub PonerNegritas()
Dim i As Long, n As Long
'recorre las filas de la columna "A"
For i = 2 To Range("A" & Rows.Count).End(3).Row
With Range("A" & i)
'obtiene la posición del guión "-" (de derecha a izquierda)
n = InStrRev(.Value, "-")
If n > 0 Then
'si encontró el guión, entonces pone en negritas el texto
'después del guión
.Characters(n + 2, Len(.Value)).Font.Bold = True
End If
End With
Next
End Sub

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

Código para poner en negritas el texto que está entre 2 caracteres:

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

Sub PonerNegritas_2()
Dim i As Long, m As Long, n As Long
'recorre las filas de la columna "A"
For i = 2 To Range("A" & Rows.Count).End(3).Row
With Range("A" & i)
'obtiene la posición del guión "-" (de derecha a izquierda)
m = InStr(.Value, "/")
n = InStrRev(.Value, "/")
If n > 0 Then
'si encontró el caracter, entonces pone en negritas
'el texto entre caracteres
.Characters(m + 1, n - m - 1).Font.Bold = True
End If
End With
Next
End Sub

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

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:

Cargar Combobox

Diferentes maneras de cargar datos en un combobox que se encuentra en un userform.

Cargar utilizando la propiedad RowSource, la propiedad List y el método AddItem

Carga de datos con filtro, carga de datos ordenados y desplegar las coincidencias mientras se van ingresando letras en el combobox.

Código fuente. UserForm1:

----- --

Option Explicit
Private Sub UserForm_Activate()
Dim sh As Worksheet
Dim i As Long, uf As Long, j As Long
Dim a As Variant, b As Variant
Dim c As Range
Dim dic As Object

Set sh = Sheets("Ej 1")
'última fila
uf = sh.Range("A" & Rows.Count).End(3).Row
'carga con RowSource
ComboBox2.RowSource = "'" & sh.Name & "'!A2:A" & uf
''
'carga con RowSource pero con rango nombrado
ComboBox3.RowSource = "nombres_1"
'
'carga con el método AddItem
For i = 2 To uf
ComboBox4.AddItem sh.Range("A" & i).Value
Next
'
'carga con la propiedad List
ComboBox5.List = sh.Range("A2:A" & uf).Value
'
'carga con la propiedad List pero utilizando una matriz
a = sh.Range("A2:A" & uf).Value
ComboBox6.List = a
'
'carga con AddItem pero filtrando
For Each c In sh.Range("A2:A" & uf)
If InStr(1, c.Value, "o", vbTextCompare) Then
ComboBox7.AddItem c.Value
End If
Next
'
'carga con List pero filtrando
ReDim b(1 To UBound(a, 1), 1 To 1)
For i = 1 To UBound(a, 1)
If LCase(a(i, 1)) Like "a*" Then
j = j + 1
b(j, 1) = a(i, 1)
End If
Next
ComboBox8.List = b
'
'carga con List únicos
Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(a, 1)
dic(a(i, 1)) = Empty
Next
ComboBox10.List = dic.keys
''
'carga con AddItem únicos y ordenandos
For i = 2 To uf
Call agregar(ComboBox9, sh.Range("A" & i).Value)
Next
End Sub
Sub agregar(combo As ComboBox, dato As String)
Dim n As Long
For n = 0 To combo.ListCount - 1
Select Case StrComp(combo.List(n), dato, vbTextCompare)
Case 0: Exit Sub 'ya existe en el combo y ya no lo agrega
Case 1: combo.AddItem dato, n: Exit Sub 'Es menor, lo agrega antes del comparado
End Select
Next
combo.AddItem dato 'Es mayor lo agrega al final
End Sub

----- --

Código fuente. UserForm2:

----- --

Option Explicit
Dim a() As Variant
Dim cargando As Boolean
'
Private Sub ComboBox1_Change()
Dim dato As String
Dim i As Long, j As Long
Dim b As Variant

If cargando = True Then Exit Sub
cargando = True
ReDim b(0 To UBound(a, 1), 1 To 1)

With ComboBox1
dato = .Value
.Clear
For i = 0 To UBound(a, 1)
If LCase(a(i, 0)) Like "*" & LCase(dato) & "*" Then
b(j, 1) = a(i, 0)
j = j + 1
End If
Next
.List = b
.Value = dato
.DropDown
End With

cargando = False
End Sub
Private Sub UserForm_Activate()
Dim sh As Worksheet
Dim i As Long

Set sh = Sheets("Ej 1") 'hoja de nombres

'carga con AddItem únicos y ordenandos
For i = 2 To sh.Range("A" & Rows.Count).End(3).Row
Call agregar(ComboBox1, sh.Range("A" & i).Value)
Next
a = ComboBox1.List
ComboBox1.MatchEntry = fmMatchEntryNone
End Sub
Sub agregar(combo As ComboBox, dato As String)
Dim n As Long
For n = 0 To combo.ListCount - 1
Select Case StrComp(combo.List(n), dato, vbTextCompare)
Case 0: Exit Sub 'ya existe en el combo y ya no lo agrega
Case 1: combo.AddItem dato, n: Exit Sub 'Es menor, lo agrega antes del comparado
End Select
Next
combo.AddItem dato 'Es mayor lo agrega al final
End Sub

----- --

Dictionary

Qué es el Dictionary en VBA, técnicamente es un objeto, que se utiliza para almacenar datos, puede ser una lista de productos, una lista de empleados o valores que tengan una clave.

Su función es almacenar las claves únicas en un índice y a cada clave asociar un dato.

Esto significa que a través del índice podemos localizar de manera inmediata el dato.

Literalmente es como un diccionario, donde tenemos las palabras y una definición.

En un diccionario de palabras no recorres palabra por palabra hasta llegar a la palabra que necesitas.

Con el índice accedes a su definición de manera inmediata.

Métodos revisados en los vídeos:

Add

Remove

RemoveAll

Exists

Propiedades revisadas en los vídeos:

Item

keys

Items

Count

CompareMode

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

Descarga el archivo con los ejercicios:

Dictionary Ejercicios

Macro para copiar datos de un libro a otro utilizando Matrices

El uso de matrices es de las mejores prácticas para realizar los procesos en memoria con una gran cantidad de datos.

En este ejemplo, la macro copia los datos de las columnas del libro 1 y las pega en el libro 2, pero en el libro 2 las columnas están en diferente orden.

En el vídeo también explico la manera de utilizar el diccionario (Dictionary) para indexar los títulos de las columnas.

Código para copiar Datos:

Sub Comparar_Datos()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim dic As Object
Dim a As Variant, b As Variant
Dim i As Long, j As Long, lr As Long, lc As Long

Set dic = CreateObject("Scripting.Dictionary")
Set sh1 = Workbooks("Libro1").Sheets("Matriz")
Set sh2 = Workbooks("Libro2").Sheets("Datos")

lr = sh1.Range("A:D").Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
lc = sh1.Cells(4, Columns.Count).End(1).Column
a = sh1.Range("A4", sh1.Cells(lr, lc)).Value
b = sh2.Range("A4").Resize(UBound(a, 1), UBound(a, 2)).Value

'recorre las columnas del libro2 para armar el diccionario
For j = 1 To UBound(b, 2)
dic(b(1, j)) = j 'almacena el título en el diccionario y como item la columna
Next

'recorre la matriz 'a' por columna, busca la columna en el diccionario
'y en esa columna almacena los datos
For j = 1 To UBound(a, 2)
If dic.exists(a(1, j)) Then
'pasa los datos de la matriz 'a' a la matriz 'b'
For i = 2 To UBound(a, 1)
b(i, dic(a(1, j))) = a(i, j)

'sh2.Range("A4").Resize(UBound(b, 1), UBound(b, 2)).Value = b

Next
End If
Next

sh2.Range("A4").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

Macro para copiar en 2 columnas diferentes en el destino:

Sub Comparar_Datos_2()

'copiar en dos columnas diferentes

Dim sh1 As Worksheet, sh2 As Worksheet

Dim dic As Object

Dim a As Variant, b As Variant

Dim i As Long, j As Long, lr As Long, lc As Long

Dim js As String, col As Variant

Set dic = CreateObject("Scripting.Dictionary")

Set sh1 = Workbooks("Libro1").Sheets("Matriz")

Set sh2 = Workbooks("Libro2").Sheets("Datos")

lr = sh1.Range("A:D").Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row

lc = sh1.Cells(4, Columns.Count).End(1).Column

a = sh1.Range("A4", sh1.Cells(lr, lc)).Value

lc = sh2.Cells(4, Columns.Count).End(1).Column 'columnas en libro2

b = sh2.Range("A4").Resize(UBound(a, 1), lc).Value

'recorre las columnas del libro2 para armar el diccionario

For j = 1 To UBound(b, 2)

If Not dic.exists(b(1, j)) Then

dic(b(1, j)) = j 'almacena el título en el diccionario y como item la columna

Else

js = dic(b(1, j)) & "|" & j

dic(b(1, j)) = js 'almacena otra columna en caso de repetirse el mismo título

End If

'recorre la matriz 'a' por columna, busca la columna en el diccionario

'y en esa columna almacena los datos

For j = 1 To UBound(a, 2)

If dic.exists(a(1, j)) Then

'pasa los datos de la matriz 'a' a la matriz 'b'

For Each col In Split(dic(a(1, j)), "|") 'para cada columna, incluso si hay repetidas

For i = 2 To UBound(a, 1)

b(i, col) = a(i, j)

End If

sh2.Range("A4").Resize(UBound(b, 1), UBound(b, 2)).Value = b

End Sub

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

Necesitas Crear Un Archivo Por Cada Clave

Necesitas dividir la información de tu hoja en varios archivos en función de las claves que tienes en una columna.

Para cada grupo de claves DEBES generar un archivo con la información correspondiente.

Te muestro cómo generar todos los archivos con solamente presionar un botón.

Código:

Sub Crear_Archivos()
'Por Dante Amor
'VARIABLES
Dim wb As Workbook
Dim sh As Worksheet
Dim c As Range, celda As Range, col As Range
Dim wPath As String, col_clave As String
Dim lr As Long, lc As Long, fila As Long
Dim ky As Variant
'
'
'DATOS INICIALES
Set sh = ActiveSheet 'Nombre de la hoja con los datos

On Error Resume Next
With Application
Set celda = .InputBox("Selecciona la primera celda de tus encabezados", _
"CURSO DE EXCEL Y MACROS", Range("A1").Address, Type:=8)
If celda Is Nothing Then Exit Sub
Set col = .InputBox("Selecciona la columna con las claves", _
"CURSO DE EXCEL Y MACROS", Range("B:B").Address, Type:=8)
If col Is Nothing Then Exit Sub
End With
On Error GoTo 0
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Selecciona la carpeta destino"
.InitialFileName = ThisWorkbook.Path
If .Show <> -1 Then Exit Sub
wPath = .SelectedItems(1) & "\"
End With

col_clave = Split(col.Address(0, 0), ":")(0) 'Columna clave referencia para crear libros

'AMBIENTE
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'
'VALORES
If sh.AutoFilterMode Then sh.AutoFilterMode = False
fila = celda.Row
lc = sh.Cells(fila, Columns.Count).End(1).Column
lr = sh.Range(col_clave & Rows.Count).End(3).Row
'
'PROCESO
With CreateObject("Scripting.Dictionary")
'almacena en un índice los valores únicos de la columna clave
For Each c In sh.Range(sh.Cells(fila + 1, col_clave), _
sh.Cells(lr, col_clave))
.Item(c.Value) = Empty
Next
For Each ky In .Keys
'filtra los datos por cada clave
sh.Range(celda, sh.Cells(fila, lc)).AutoFilter Columns(col_clave).Column, ky
Set wb = Workbooks.Add(xlWBATWorksheet) 'crea nuevo libro con una hoja
sh.AutoFilter.Range.Copy Range(celda.Address) 'copia los datos filtrados
wb.SaveAs wPath & ky & ".xlsx", xlOpenXMLWorkbook 'guarda el archivo
wb.Close False
Next
sh.ShowAllData
End With
'
'AMBIENTE
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Archivos generados", vbInformation, "CURSOS DE EXCEL Y MACROS"
End Sub

Instrucciones:

Realiza los siguientes pasos para crear un botón y ejecutar la macro

1. Abre tu libro de Excel

2. Para abrir VBA-Macros y poder pegar la macro, Presiona Alt + F11

3. En el menú elige Insertar / Módulo

4. Copia el código que está arriba.

5. En el panel del lado derecho pega la macro

6. Ahora para crear un botón, puedes hacer lo siguiente:

7. Inserta una imagen en tu libro, elige del menú Insertar / Imagen / Autoformas

8. Elige una imagen y con el Mouse, dentro de tu hoja, presiona clic y arrastra el Mouse para hacer grande la imagen.

9. Presiona clic derecho dentro de la imagen y selecciona: Asignar macro. Selecciona: Crear_Archivos

10. Presiona Aceptar.

12. Para ejecutarla presiona clic en la imagen.