PROGRAMAR EN VBA MACROS PARA EXCEL: noviembre 2018

Como Copiar y Eliminar Item al Pasar de Listbox a Otro Listbox con Doble Click y Vicerversa






En este post se mostrará Como Pasar Registros de Un Listbox a Otro Listbox Eliminar Item y Viceversa Haciendo Doble Click; es una variante de lo realizado al presionar Enter y se expuso en Como Copiar y Eliminar Item al Pasar de Listbox a Otro y Viceversa Listbox con Enter.

La macro permite al hacer doble click en el Listbox pasar los datos a otro listbox, eliminando los datos del primer listbox; en el segundo listbox se puede hacer lo mismo es decir presionando doble click se pasa al primer listbox eliminando los registros del del segundo listbox.

Si te estás iniciando en la operación de Excel o requieres afirmar conocimientos, recomiendo leer un excelente libro sobre Excel que te ayudará operar las planillas u hojas de cálculo, haz click acá, si quieres aprender sobre Excel, en inglés, entonces debes hacer click here. Si lo que necesitas es aprender o profundizar sobre la programación de macros con VBA este es unos de los mejores cursos on line que he visto en internet.

  

Suscribe a nuestro canal para que YouTube te avise cuando se suba nuevo contenido al canal, en el vídeo encontrarás una explicación gráfica y detallada del ejemplo que se muestra en este post.





 



Se sugiere descargar el ejemplo de esta forma será más fácil entender el ejemplo, al presionar el botón que se encuentra en la hoja de Excel del libro que contiene el ejemplo, se muestra un formulario con dos listbox, el Listbox1 con fondo color Rosa y el Listbox2 con fondo color Blanco.

Si se hace doble click sobre un ítem seleccionado en el primer listbox, se pasarán los datos al segundo Listbox eliminando los registros del Listbox con fondo Rosa, en el caso que no hayamos equivocado o simplemente, porque no se requiera que ese ítem este en el Listbox2, se puede hacer doble click en este Listbox2 pasar el ítem nuevamente el Listbox1 y eliminar el registro del Listbox con fondo Blanco.

⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛
Quizá sea de utilidad también

Como agregar un botón maximizar minimizar a un formulario de Excel


Como sumar celdas de un mismo color

Como enviar mail con outlook adjuntando archivo PDF

El código se debe escribir en el evento doble click del Listbox1 y Listbox2, obviamente haciendo referencia a cada control correspondiente, básicamente el código es el siguiente:

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
On Error Resume Next
Set a = UserForm1.ListBox1
Set b = UserForm1.ListBox2
fila = UserForm1.ListBox1.ListIndex

El códigos anteriores permiten crear un objeto con el Listbox1 y Listbox2 y determinar la fila del Listbox con el ítem seleccionado.


b.AddItem a.List(fila, 0)
b.List(b.ListCount - 1, 1) = a.List(fila, 1)
b.List(b.ListCount - 1, 2) = a.List(fila, 2)
b.List(b.ListCount - 1, 3) = a.List(fila, 3)
a.RemoveItem a.ListIndex

Los códigos anteriores, permiten pasar los datos de un Listbox a otro Listbox y con la última línea de código remover o borrar los registros del Listbox, lo anteriormente especificado se debe realizar con el Listbox2 en su evento doble click.

La descarga del ejemplo se realiza desde el final del post y seguidamente se muestra el código del ejemplo Como Copiar y Eliminar Registro al Pasar de un Listbox a Otro con Doble Click.


Código que se inserta en un Formulario de Excel

'**************https://programarexcel.com  **** https://youtube.com/programarexcel*********



Private Sub CommandButton1_Click()
Unload Me
End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
On Error Resume Next
Set a = UserForm1.ListBox1
Set b = UserForm1.ListBox2
fila = UserForm1.ListBox1.ListIndex
b.AddItem a.List(fila, 0)
b.List(b.ListCount - 1, 1) = a.List(fila, 1)
b.List(b.ListCount - 1, 2) = a.List(fila, 2)
b.List(b.ListCount - 1, 3) = a.List(fila, 3)
a.RemoveItem a.ListIndex
End Sub
Private Sub ListBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
On Error Resume Next
Set aa = UserForm1.ListBox1
Set bb = UserForm1.ListBox2
fila = bb.ListIndex
aa.AddItem bb.List(fila, 0)
aa.List(aa.ListCount - 1, 1) = bb.List(fila, 1)
aa.List(aa.ListCount - 1, 2) = bb.List(fila, 2)
aa.List(aa.ListCount - 1, 3) = bb.List(fila, 3)
bb.RemoveItem bb.ListIndex
End Sub
Private Sub TextBox1_Change()
On Error Resume Next
Set b = Sheets("Hoja1")
uf = b.Range("A" & Rows.Count).End(xlUp).Row
If Trim(TextBox1.Value) = "" Then
     'Me.ListBox1.List() = b.Range("A2:H" & uf).Value
     Me.ListBox1.RowSource = "Hoja1!A2:D" & uf
   Exit Sub
End If
b.AutoFilterMode = False
Me.ListBox1.Clear
Me.ListBox1.RowSource = Clear
For i = 2 To uf
   strg = b.Cells(i, 1).Value
   If UCase(strg) Like "*" & UCase(TextBox1.Value) & "*" Then
       Me.ListBox1.AddItem b.Cells(i, 1)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = b.Cells(i, 2)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 2) = b.Cells(i, 3)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 3) = b.Cells(i, 4)
   End If
Next i
Me.ListBox1.ColumnWidths = "20 pt;90pt;80 pt;80 pt"
End Sub
Private Sub TextBox2_Change()
On Error Resume Next
Set b = Sheets("Hoja1")
uf = b.Range("A" & Rows.Count).End(xlUp).Row
If Trim(TextBox2.Value) = "" Then
     'Me.ListBox1.List() = b.Range("A2:H" & uf).Value
     Me.ListBox1.RowSource = "Hoja1!A2:H" & uf
   Exit Sub
End If
b.AutoFilterMode = False
Me.ListBox1.Clear
Me.ListBox1.RowSource = Clear
For i = 2 To uf
   strg = b.Cells(i, 2).Value
   If UCase(strg) Like "*" & UCase(TextBox2.Value) & "*" Then
       Me.ListBox1.AddItem b.Cells(i, 1)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = b.Cells(i, 2)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 2) = b.Cells(i, 3)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 3) = b.Cells(i, 4)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 4) = b.Cells(i, 5)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 5) = b.Cells(i, 6)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 6) = b.Cells(i, 7)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 7) = b.Cells(i, 8)
   End If
Next i
Me.ListBox1.ColumnWidths = "20 pt;90pt;80 pt;80 pt"
End Sub

Private Sub UserForm_Initialize()
Dim fila As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set b = Sheets("Hoja2")
uf = b.Range("A" & Rows.Count).End(xlUp).Row
uc = b.Cells(1, Columns.Count).End(xlToLeft).Address
wc = Mid(uc, InStr(uc, "$") + 1, InStr(2, uc, "$") - 2)
With Me.ListBox1
    .ColumnCount = 4
    .ColumnWidths = "20 pt;90pt;80 pt;80 pt"
    '.RowSource = "Hoja2!A2:" & wc & uf
End With
With Me.ListBox2
    .ColumnCount = 4
    .ColumnWidths = "25 pt;90pt;60 pt;60 pt"
End With

uf = b.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To uf
       Me.ListBox1.AddItem b.Cells(i, 1)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = b.Cells(i, 2)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 2) = b.Cells(i, 3)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 3) = b.Cells(i, 4)

Next i

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Código que se inserta en un módulo

'**************https://programarexcel.com  **** https://youtube.com/programarexcel*********

Sub muestra1()
UserForm1.Show
End Sub

⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛


Si te fue de utilidad puedes INVITARME UN CAFÉ y de esta manera ayudar a seguir manteniendo la página, CLICK para descargar en ejemplo en forma gratuita.


If this post was helpful INVITE ME A COFFEE and so help keep up the page, CLICK to download free example.


Si te gustó por favor compártelo con tus amigos
If you liked please share it with your friends      

Como Enviar Whatsapp Personalizado en Forma Masiva con Excel






A pedido de un suscriptor de nuestro canal de YuoTube se presenta Como Enviar Mensaje Personalizado de Whatsapp en Forma Masiva a Cada Contacto Registrado en Excel, ya se ha tratado el tema de utilizar Excel para enviar mensajes de Whatsapp en el link se podrán observar los ejemplos anteriores sobre Envío de Whatsapp con Excel.

Recomiendo leer un excelente libro sobre Excel que te ayudará operar las planillas u hojas de cálculo, haz click acá, si quieres aprender sobre Excel, en inglés, entonces debes hacer click here. Si lo que necesitas es aprender o profundizar sobre la programación de macros con VBA este es unos de los mejores cursos on line que he visto en internet.

  

Suscribe a nuestro canal para que YouTube te avise cuando se suba nuevo contenido al canal, en el vídeo encontrarás una explicación gráfica y detallada del ejemplo que se muestra en este post.






 


Para proceder a Enviar un Mensaje Personalizado de Whatsapp con Excel, básicamente se realiza un bucle y se aplica el procedimiento ya visto para enviar mensajes de Whatsapp desde Excel, al descargar el ejemplo se pude observar un listado o pequeña base de datos con los contactos en la columna A, los respectivos números de teléfono en la columna B y el mensaje personalizado que se le enviará a cada contacto en la Columna C.

El requisito necesario para poder enviar Whatsapp con Excel es tener previamente habilitado WebWhatsapp, desde acá se obtiene el aplicativo; la macro utiliza la API oficial de Whatsapp para poder enviar mensajes a través de Excel, no es necesario tener cargado en contacto en el teléfono para poder enviarle un mensaje Whatsapp con Excel.

El bucle se inicia en la fila dos hasta la última fila con datos de la Columna A, se cargan en las variables uf, la última fila con datos; en la variable telwhatsapp, el teléfono del contacto y en texwhatsapp el mensaje propiamente dicho, se usan los siguientes códigos:

uf = a.Range("A" & Rows.Count).End(xlupo).Row

For x = 2 To uf
telwhatsapp = a.Cells(x, "B")
textwhatsapp = a.Cells(x, "C")

⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛
Quizá sea de utilidad también

Como Llenar Listbox con más de 10 columnas


Como Cargar Listbox con Datos Provenientes de Varias Hojas

Como hacer un link o hiperlink a google maps con Excel

Obtenido el número de teléfono para enviar Whatsapp se la macro navega hasta el link de la API de Whatsapp, cargando el número de teléfono y el mensaje, con el siguiente código:

mylinkwhatsapp = "https://api.whatsapp.com/send?phone=" & telwhatsapp & "&text=" & textwhatsapp
ActiveWorkbook.FollowHyperlink mylinkwhatsapp

Atento a que WebWhatsapp no es compatible con InternetExplorer dificulta la comunicación con el lenguaje de VBA - Excel, por lo que se apela a SenKey, esto envía los impulsos de teclas necesarios para poder lograr enviar el mensaje.

Como la aplicación de Whatsapp Web se va cargando con cada comando que se envía desde Excel, se debe esperar unos segundos para que se cargue la página Web, es decir se debe deterner la macro una vez cargada la página se procede a enviar el siguiente código, la rápidez con la que se envía el Whatsapp va a variar dependiendo de la velocidad de internet con la que se cuente, es por ello que cada uno debe modificar el tiempo en base a la velocidad de internet que posea, modificando las siguientes lineas:

Application.Wait (Now + TimeValue("00:00:05"))

En el código anterior 05 representa que la macro espera 5 segundos hasta que la página se cargue y mande el próximo comando, esto se puede modificar en más o menos, dependiendo de la velocidad de internet que se posea.

Sugiero ver el vídeo explicativo del ejemplo llamado Como Enviar Masivamente Whatsapp Personalizados desde Excel, seguidamente se muestra el código y al final está el link para descargar el ejemplo de Excel que envía Whastapp.


Código que se inserta en un Modulo de Excel

'**************https://programarexcel.com  **** https://youtube.com/programarexcel*********



#If VBA7 And Win64 Then
'Si es de 64 bits
Public Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr
Public Declare PtrSafe Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Public Declare PtrSafe Function GetWindowLongPtr Lib "USER32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Public Declare PtrSafe Function SetWindowLongPtr Lib "USER32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Public Declare PtrSafe Function DrawMenuBar Lib "USER32" (ByVal hwnd As Long) As LongPtr
Public Declare PtrSafe Function RegOpenKeyA Lib "advapire32.dll" (ByVal hKey As LongPtr, ByVal lpSubKey As String, phkResult As LongPtr) As LongPtr
#Else
'Si es de 32 bits
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Declare Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function GetWindowLong Lib "USER32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "USER32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function DrawMenuBar Lib "USER32" (ByVal hwnd As Long) As Long
Public Declare Function RegOpenKeyA Lib "advapire32.dll" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
#End If
Public telwhatsapp, textwhatsapp

'*********** by marcrodos **** https://programarexcel.com  ***  https://www.youtube.com/c/programarexcel?sub_confirmation=1 ********

Sub EnviaWhatsapp()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set a = Sheets("Hoja1")
uf = a.Range("A" & Rows.Count).End(xlupo).Row

For x = 2 To uf
telwhatsapp = a.Cells(x, "B")
textwhatsapp = a.Cells(x, "C")

mylinkwhatsapp = "https://api.whatsapp.com/send?phone=" & telwhatsapp & "&text=" & textwhatsapp
ActiveWorkbook.FollowHyperlink mylinkwhatsapp

Application.Wait (Now + TimeValue("00:00:05"))
ActiveWindow.Application.SendKeys "{TAB}"
Application.Wait (Now + TimeValue("00:00:01"))
ActiveWindow.Application.SendKeys "{TAB}"
Application.Wait (Now + TimeValue("00:00:05"))
ActiveWindow.Application.SendKeys "(~)" 'énvia enter para enviar mensaje
Application.Wait (Now + TimeValue("00:00:18"))
ActiveWindow.Application.SendKeys "(~)"
Next x
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Sub macro1(control As IRibbonControl)
On Error Resume Next
respuesta = MsgBox("¿Seguro desea enviar Whatsapp a los contactos listados?", vbCritical + vbYesNo)
If respuesta = 6 Then
Call EnviaWhatsapp
End If
End Sub

⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛



Si te fue de utilidad puedes INVITARME UN CAFÉ y de esta manera ayudar a seguir manteniendo la página, CLICK para descargar en ejemplo en forma gratuita.


If this post was helpful INVITE ME A COFFEE and so help keep up the page, CLICK to download free example.


Si te gustó por favor compártelo con tus amigos
If you liked please share it with your friends      

Como Copiar y Eliminar Item al Pasar de Listbox a Otro Listbox con Enter y Viceversa







En este ejemplo se verá Como Pasar Datos de un Listbox a Otro y Viceversa con Enter, es decir se muestra como se pueden pasar datos al presionar enter de un Listbox a otro Listbox , los datos que se van pasando se copian en el segundo Listbox y en el primer Listbox se borra el item.

En caso que se requiera revetir la operación es decir pasar datos del segundo Listbox al primer Listbox , al presionar Enter en esté último Listbox se pasa el dato al primer Listbox y se borra el item en del segundo Listbox.

Requieres afirmar conocimientos, recomiendo leer un excelente libro sobre Excel que te ayudará operar las planillas u hojas de cálculo, haz click acá, si quieres aprender sobre Excel, en inglés, entonces debes hacer click here. Si lo que necesitas es aprender o profundizar sobre la programación de macros con VBA este es unos de los mejores cursos on line que he visto en internet.

  

Suscribe a nuestro canal para que YouTube te avise cuando se suba nuevo contenido al canal, en el vídeo encontrarás una explicación gráfica y detallada del ejemplo que se muestra en este post.






 


Se aconseja descargar el ejemplo para su más fácil y rápido entendimiento, al abrir el libro se observa un botón que presionando muestra un formulario que básicamente contiene dos listbox uno con fondo blanco Listbox1 y otro con fondo celeste Listbox2.

Al seleccionar un ítem y presionar Enter en el Listbox1 se el ítem al Listbox2, borrándose el dato en el Listbox1.

Si se requiere ya sea por error o por lo que sea revertir la acción, presionando un ítem en el Listbox2 se pasa el registro al Listbox1, borrándose el dato en el Listbox2.

En primer lugar se debe detectar, en el evento KeyPress, cuando se presiona Enter en el Listbox1 tenga el foco, eso se hacer apelando a la tabla de código Ascii, donde 13 representa la tecla Enter, previo se crea un objeto con el Listbox1 (a) y Listox2 (b), se usa el siguiente código:

Set a = UserForm1.ListBox1
Set b = UserForm1.ListBox2
If KeyAscii = 13 Then

Se carga en la variable fila, el número de la fila seleccionada, esto nos sirve para saber que datos se deben pasar al otro listbox y a la vez que item eliminar del Listbox1, pasando los datos de un listbox a otro, con los siguientes códigos:

fila = UserForm1.ListBox1.ListIndex
b.AddItem a.List(fila, 0)
b.List(b.ListCount - 1, 1) = a.List(fila, 1)
b.List(b.ListCount - 1, 2) = a.List(fila, 2)
b.List(b.ListCount - 1, 3) = a.List(fila, 3)

La fila a eliminar del Listbox1 se realiza con el siguiente código:

a.RemoveItem a.ListIndex

⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛
Quizá sea de utilidad también

Como abrir otro libro y copiar o exportar datos del libro actual


Como llenar listbox con additem o RowSource para más de diez columnas

Como enviar Mail dependiendo de fecha

Bien ya se han pasado los datos del Listbox1 al Listbox2 y se ha eliminado la fila donde estába el item seleccionado, suponiendo el caso que se quiera volver al Listbox1 los datos pasados sea el último dato pasado o cualquiera que hayamos pasado antes, se apela a un código parecido pero se debe colocar en el evento Keypress del Listbox2, realizando los mismos pasos narrados para el Listbox1.

Es decir se crean los objetos con los Listbox1 y Listbox2, se detecta cuando se presiona Enter en Listbox2, se carga en variable fila cual es el número de fila del ítem seleccionado en el Listbox2, así:

Set aa = UserForm1.ListBox1
Set bb = UserForm1.ListBox2
If KeyAscii = 13 Then
fila = bb.ListIndex

Queda pasar los datos al Listbox1 y eliminar en el Listbox2 (fondo celeste del ejemplo) la fila que se paso al Listbox1, se hace con el siguiente código:

aa.AddItem bb.List(fila, 0)
aa.List(aa.ListCount - 1, 1) = bb.List(fila, 1)
aa.List(aa.ListCount - 1, 2) = bb.List(fila, 2)
aa.List(aa.ListCount - 1, 3) = bb.List(fila, 3)
bb.RemoveItem bb.ListIndex

Puedes descargar el ejemplo Como Copiar y Eliminar Ítem al Pasar de Listbox a Otro Listbox y Viceversa con Enter desde el el final del post, seguidamente el código completo que contiene el formulario.


Código que se inserta en un Formulario de Excel

'**************https://programarexcel.com  **** https://youtube.com/programarexcel*********



Private Sub CommandButton1_Click()
Unload Me
End Sub

Private Sub ListBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
On Error Resume Next
Set a = UserForm1.ListBox1
Set b = UserForm1.ListBox2
If KeyAscii = 13 Then
fila = UserForm1.ListBox1.ListIndex
b.AddItem a.List(fila, 0)
b.List(b.ListCount - 1, 1) = a.List(fila, 1)
b.List(b.ListCount - 1, 2) = a.List(fila, 2)
b.List(b.ListCount - 1, 3) = a.List(fila, 3)
a.RemoveItem a.ListIndex
End If
End Sub

Private Sub ListBox2_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
On Error Resume Next
Set aa = UserForm1.ListBox1
Set bb = UserForm1.ListBox2
If KeyAscii = 13 Then
fila = bb.ListIndex
aa.AddItem bb.List(fila, 0)
aa.List(aa.ListCount - 1, 1) = bb.List(fila, 1)
aa.List(aa.ListCount - 1, 2) = bb.List(fila, 2)
aa.List(aa.ListCount - 1, 3) = bb.List(fila, 3)
bb.RemoveItem bb.ListIndex
End If
End Sub

Private Sub TextBox1_Change()
On Error Resume Next
Set b = Sheets("Hoja1")
uf = b.Range("A" & Rows.Count).End(xlUp).Row
If Trim(TextBox1.Value) = "" Then
     'Me.ListBox1.List() = b.Range("A2:H" & uf).Value
     Me.ListBox1.RowSource = "Hoja1!A2:D" & uf
   Exit Sub
End If
b.AutoFilterMode = False
Me.ListBox1.Clear
Me.ListBox1.RowSource = Clear
For i = 2 To uf
   strg = b.Cells(i, 1).Value
   If UCase(strg) Like "*" & UCase(TextBox1.Value) & "*" Then
       Me.ListBox1.AddItem b.Cells(i, 1)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = b.Cells(i, 2)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 2) = b.Cells(i, 3)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 3) = b.Cells(i, 4)
   End If
Next i
Me.ListBox1.ColumnWidths = "20 pt;90pt;80 pt;80 pt"
End Sub
Private Sub TextBox2_Change()
On Error Resume Next
Set b = Sheets("Hoja1")
uf = b.Range("A" & Rows.Count).End(xlUp).Row
If Trim(TextBox2.Value) = "" Then
     'Me.ListBox1.List() = b.Range("A2:H" & uf).Value
     Me.ListBox1.RowSource = "Hoja1!A2:H" & uf
   Exit Sub
End If
b.AutoFilterMode = False
Me.ListBox1.Clear
Me.ListBox1.RowSource = Clear
For i = 2 To uf
   strg = b.Cells(i, 2).Value
   If UCase(strg) Like "*" & UCase(TextBox2.Value) & "*" Then
       Me.ListBox1.AddItem b.Cells(i, 1)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = b.Cells(i, 2)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 2) = b.Cells(i, 3)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 3) = b.Cells(i, 4)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 4) = b.Cells(i, 5)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 5) = b.Cells(i, 6)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 6) = b.Cells(i, 7)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 7) = b.Cells(i, 8)
   End If
Next i
Me.ListBox1.ColumnWidths = "20 pt;90pt;80 pt;80 pt"
End Sub

Private Sub UserForm_Initialize()
Dim fila As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set b = Sheets("Hoja2")
uf = b.Range("A" & Rows.Count).End(xlUp).Row
uc = b.Cells(1, Columns.Count).End(xlToLeft).Address
wc = Mid(uc, InStr(uc, "$") + 1, InStr(2, uc, "$") - 2)
With Me.ListBox1
    .ColumnCount = 4
    .ColumnWidths = "20 pt;90pt;80 pt;80 pt"
    '.RowSource = "Hoja2!A2:" & wc & uf
End With
With Me.ListBox2
    .ColumnCount = 4
    .ColumnWidths = "25 pt;90pt;60 pt;60 pt"
End With

uf = b.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To uf
       Me.ListBox1.AddItem b.Cells(i, 1)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = b.Cells(i, 2)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 2) = b.Cells(i, 3)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 3) = b.Cells(i, 4)

Next i

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub






Código que se inserta en un módulo

'**************https://programarexcel.com  **** https://youtube.com/programarexcel*********

Sub muestra1()
UserForm1.Show
End Sub

⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛


Si te fue de utilidad puedes INVITARME UN CAFÉ y de esta manera ayudar a seguir manteniendo la página, CLICK para descargar en ejemplo en forma gratuita.


If this post was helpful INVITE ME A COFFEE and so help keep up the page, CLICK to download free example.


Si te gustó por favor compártelo con tus amigos
If you liked please share it with your friends      

Como Copiar Todos Datos Listbox a Hoja de Excel






En este post se presentará una macro que muestra Como Copiar Todos los Datos del Listbox a Hoja de Excel; que solicitó un suscriptor del nuestro canal de YouTube, necesitaba saber como pasar los datos contenidos en un Listbox a la Hoja de Excel, pero no el dato seleccionado como se mostró en Como pasar Dato Seleccionado de Listbox a Hoja Excel, se requería pasar todos los datos que contenía o se estaban mostrando en el Listbox de Excel.

Si te estás iniciando en la operación de Excel o requieres afirmar conocimientos, recomiendo leer un excelente libro sobre Excel que te ayudará operar las planillas u hojas de cálculo, haz click acá, si quieres aprender sobre Excel, en inglés, entonces debes hacer click here. Si lo que necesitas es aprender o profundizar sobre la programación de macros con VBA este es unos de los mejores cursos on line que he visto en internet.

  

Suscribe a nuestro canal para que YouTube te avise cuando se suba nuevo contenido al canal, en el vídeo encontrarás una explicación gráfica y detallada del ejemplo que se muestra en este post.






 


Este ejemplo de Macro se muestra como copiar los datos que se están mostrando en el Listbox y pasarlos a la hoja de Excel, se pasarán todos los datos no el que tenga actualmente seleccionado el Listbox.

Al descarar el ejemplo, se observa un botón, al ejecutar se muestra un formulario con dos Listbox, haciendo Doble Click o presionando Enter en el Listbox de la Izquierda, se pasan los datos requeridos al listbox de la derecha, una vez seleccionados los datos requeridos, se debe presionar el botón que se encuentra en la parte inferior del formulario para pasar los datos del listbox de la derecha a la hoja3 de Excel.

El código que permite pasar los datos del Listbox a la hoja de Excel, en primero lugar crea una objeto con la hoja3 del Libro de Excel que es donde se copiaran los datos del Listbox, borra todos los datos por si existiera algún dato ya registrado en dicha hoja, se hace con el siguiente código:

Set a = Sheets("Hoja3")
a.Cells.Clear

⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛
Quizá sea de utilidad también

Como filtrar por cliente rango de fecha y totalizar importes en formulario


Como consultar datos en base de Excel mediante varios criterios con SQL

Como agregar iconos personalizados incrustados al Menu Cinta de Opciones o Ribbon de Excel



Luego se copian los datos de la cabecera de los datos de la hoja uno a la hoja tres, en el siguiente link se puede aprender más sobre como copiar datos en Excel.

Sheets("Hoja1").Range("A1:D1").Copy Destination:=a.Range("A1")

Luego se hace un bucle que recorre todas las filas del listbox hasta la última procediendo a copiar los datos del listbox  a la hoja de Excel, lo cual se logra con los siguientes códigos:

filaedit = 2
For x = 0 To Me.ListBox2.ListCount - 1
a.Cells(filaedit, "A") = ListBox2.List(x, 0)
a.Cells(filaedit, "B") = ListBox2.List(x, 1)
a.Cells(filaedit, "C") = ListBox2.List(x, 2)
a.Cells(filaedit, "D") = ListBox2.List(x, 3)
filaedit = filaedit + 1
Next x

Se debe tener en cuenta que se copiaran todos los datos que se están mostrando en el listbox, no solo el dato seleccionado, el código del ejemplo denominado Como Copiar Todos los Datos del Listbox a Hoja Excel, se descarga desde el final del post, no posee ninguna restricción, seguidamente el código completo de todo el formulario de Excel.

Código que se inserta en un Formulario de Excel

'**************https://programarexcel.com  **** https://youtube.com/programarexcel*********



Private Sub CommandButton1_Click()
Set a = Sheets("Hoja3")
a.Cells.Clear
Sheets("Hoja1").Range("A1:D1").Copy Destination:=a.Range("A1")

filaedit = 2
For x = 0 To Me.ListBox2.ListCount - 1
a.Cells(filaedit, "A") = ListBox2.List(x, 0)
a.Cells(filaedit, "B") = ListBox2.List(x, 1)
a.Cells(filaedit, "C") = ListBox2.List(x, 2)
a.Cells(filaedit, "D") = ListBox2.List(x, 3)
filaedit = filaedit + 1
Next x
MsgBox ("Los datos se copiaron con éxito"), vbInformation, "AVISO"
End Sub

Private Sub CommandButton2_Click()
Unload Me
End Sub

Private Sub ListBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
On Error Resume Next
Set a = UserForm1.ListBox1
Set b = UserForm1.ListBox2
If KeyAscii = 13 Then
fila = UserForm1.ListBox1.ListIndex
b.AddItem a.List(fila, 0)
b.List(b.ListCount - 1, 1) = a.List(fila, 1)
b.List(b.ListCount - 1, 2) = a.List(fila, 2)
b.List(b.ListCount - 1, 3) = a.List(fila, 3)
a.RemoveItem a.ListIndex
End If
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
On Error Resume Next
Set a = UserForm1.ListBox1
Set b = UserForm1.ListBox2
fila = UserForm1.ListBox1.ListIndex
b.AddItem a.List(fila, 0)
b.List(b.ListCount - 1, 1) = a.List(fila, 1)
b.List(b.ListCount - 1, 2) = a.List(fila, 2)
b.List(b.ListCount - 1, 3) = a.List(fila, 3)
a.RemoveItem a.ListIndex
End Sub
Private Sub ListBox2_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
On Error Resume Next
Set aa = UserForm1.ListBox1
Set bb = UserForm1.ListBox2
If KeyAscii = 13 Then
fila = bb.ListIndex
aa.AddItem bb.List(fila, 0)
aa.List(aa.ListCount - 1, 1) = bb.List(fila, 1)
aa.List(aa.ListCount - 1, 2) = bb.List(fila, 2)
aa.List(aa.ListCount - 1, 3) = bb.List(fila, 3)
bb.RemoveItem bb.ListIndex
End If
End Sub
Private Sub TextBox1_Change()
On Error Resume Next
Set b = Sheets("Hoja1")
uf = b.Range("A" & Rows.Count).End(xlUp).Row
If Trim(TextBox1.Value) = "" Then
     'Me.ListBox1.List() = b.Range("A2:H" & uf).Value
     Me.ListBox1.RowSource = "Hoja1!A2:D" & uf
   Exit Sub
End If
b.AutoFilterMode = False
Me.ListBox1.Clear
Me.ListBox1.RowSource = Clear
For i = 2 To uf
   strg = b.Cells(i, 1).Value
   If UCase(strg) Like "*" & UCase(TextBox1.Value) & "*" Then
       Me.ListBox1.AddItem b.Cells(i, 1)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = b.Cells(i, 2)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 2) = b.Cells(i, 3)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 3) = b.Cells(i, 4)
   End If
Next i
Me.ListBox1.ColumnWidths = "20 pt;90pt;80 pt;80 pt"
End Sub
Private Sub TextBox2_Change()
On Error Resume Next
Set b = Sheets("Hoja1")
uf = b.Range("A" & Rows.Count).End(xlUp).Row
If Trim(TextBox2.Value) = "" Then
     'Me.ListBox1.List() = b.Range("A2:H" & uf).Value
     Me.ListBox1.RowSource = "Hoja1!A2:H" & uf
   Exit Sub
End If
b.AutoFilterMode = False
Me.ListBox1.Clear
Me.ListBox1.RowSource = Clear
For i = 2 To uf
   strg = b.Cells(i, 2).Value
   If UCase(strg) Like "*" & UCase(TextBox2.Value) & "*" Then
       Me.ListBox1.AddItem b.Cells(i, 1)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = b.Cells(i, 2)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 2) = b.Cells(i, 3)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 3) = b.Cells(i, 4)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 4) = b.Cells(i, 5)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 5) = b.Cells(i, 6)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 6) = b.Cells(i, 7)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 7) = b.Cells(i, 8)
   End If
Next i
Me.ListBox1.ColumnWidths = "20 pt;90pt;80 pt;80 pt"
End Sub

Private Sub UserForm_Initialize()
Dim fila As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set b = Sheets("Hoja2")
uf = b.Range("A" & Rows.Count).End(xlUp).Row
uc = b.Cells(1, Columns.Count).End(xlToLeft).Address
wc = Mid(uc, InStr(uc, "$") + 1, InStr(2, uc, "$") - 2)
With Me.ListBox1
    .ColumnCount = 4
    .ColumnWidths = "20 pt;90pt;80 pt;80 pt"
    '.RowSource = "Hoja2!A2:" & wc & uf
End With
With Me.ListBox2
    .ColumnCount = 4
    .ColumnWidths = "25 pt;90pt;60 pt;60 pt"
End With

uf = b.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To uf
       Me.ListBox1.AddItem b.Cells(i, 1)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = b.Cells(i, 2)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 2) = b.Cells(i, 3)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 3) = b.Cells(i, 4)

Next i

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub


Código que se inserta en un módulo

'**************https://programarexcel.com  **** https://youtube.com/programarexcel*********

Sub muestra1()
UserForm1.Show
End Sub

⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛


Si te fue de utilidad puedes INVITARME UN CAFÉ y de esta manera ayudar a seguir manteniendo la página, CLICK para descargar en ejemplo en forma gratuita.


If this post was helpful INVITE ME A COFFEE and so help keep up the page, CLICK to download free example.


Si te gustó por favor compártelo con tus amigos
If you liked please share it with your friends