Mostrando las entradas con la etiqueta Macros. 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

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

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

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

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

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.