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
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
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
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
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
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.
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
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
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
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 __________________
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
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.
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
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 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)
Next
Next
End If
Next
sh2.Range("A4").Resize(UBound(b, 1), UBound(b, 2)).Value = b
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 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
