PROGRAMAR EN VBA MACROS PARA EXCEL

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