PROGRAMAR EN VBA MACROS PARA EXCEL: diciembre 2018

Como Exportar Desde Excel y Guardar Archivo TXT Separado por Tabulaciones






En el ejemplo que a continuación se detalla, se muestra como se puede Exportar de Excel a TXT con Campos Delimitados por Tabulaciones, la macro de Excel creará un archivo TXT, recorrerá todas la filas Excel exportando los datos al fichero TXT de formato plano.

En el siguiente playlist encontrarás varios ejemplos de macros con el tema de exportar e importar de Excel a TXT y TXT a 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.








 


Al descargar el fichero se puede observar un botón que al presionarlo ejecuta la macro exportando todos los datos contenidos en la Hoja1 a un archivo TXT creado por macro de Excel.

En primer lugar la macro de Excel determina cual es el nombre del archivo actual, es decir el archivo que contiene la macro, luego utiliza ese nombre para crear un Fichero TXT cuyo nombre es igual al del archivo con la macro, pero con extensión TXT, se usan los siguientes códigos:

nom = ActiveWorkbook.Name

pto = InStr(nom, ".")

nomarch = Left(nom, pto - 1)

myfile = ThisWorkbook.Path & "\" & nomarch & ".txt" 


Luego la macro de Excel carga en la variable "cara" cual va a ser el caracter delimitador de los datos que va a contener el TXT.

También se determinar la última fila con datos para poder realizar un bucle desde el dato inicial hasta el último dato de la base de datos, se usa la siguiente codificación:

cara = vbTab 'tabulación para separar o delimitar caracteres

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

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

Como crear una factura con excel, guardarla y enviarla por mail automáticamente


Como enviar mail con archivo Excel y PDF mediante Outlook con Excel

Como hacer un link o hiperlink a google maps con Excel

La macro en forma posterior crea el Archivo TXT para ello se usa el siguiente código.

Open myfile For Output As #1

Luego inicia un bucle entre la primer y última fila con datos cargando en cada unas de las variables el dato correspondiente a la fila del bucle y la columna 1 a 7 que es donde está la base de datos, los códigos usados son:

C1 = Cells(i, 1)

C2 = Cells(i, 2)

C3 = Cells(i, 3)

C4 = Cells(i, 4)

C5 = Cells(i, 5)

C6 = Cells(i, 6)

C7 = Cells(i, 7)


Por último se concatenan los datos y se envía al TXT, con el siguiente código:

Print #1, C1 & cara & C2 & cara & C3 & cara & C4 & cara & C5 & cara & C6 & cara & C7

El ejemplo Como Exportar Desde Excel a TXT Delimitado por Tabulaciones, se puede descarga desde el link del final y a continuación se podrá observar toda la codificación del ejemplo de macro presentado en este post.


Código que se inserta en un módulo

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


Sub ExportaTXTDelimitadoTabulaciones()

Dim i As Double

On Error Resume Next

Set a = Sheets("Hoja1")

nom = ActiveWorkbook.Name

pto = InStr(nom, ".")

nomarch = Left(nom, pto - 1)

myfile = ThisWorkbook.Path & "\" & nomarch & ".txt"

cara = vbTab 'tabulación para separar o delimitar caracteres

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


Open myfile For Output As #1

For i = 2 To uf

C1 = Cells(i, 1)

C2 = Cells(i, 2)

C3 = Cells(i, 3)

C4 = Cells(i, 4)

C5 = Cells(i, 5)

C6 = Cells(i, 6)

C7 = Cells(i, 7)

Print #1, C1 & cara & C2 & cara & C3 & cara & C4 & cara & C5 & cara & C6 & cara & C7

Next i

Close

MsgBox ("El archivo txt se creo con éxito"), vbInformation, "AVISO"

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 Eliminar Datos Duplicados en Excel






La Macro de Excel que se muestra permite Eliminar los Datos Duplicados de Columnas de Excel, es decir analizará una columna determinada en busca de datos duplicados, desde la primer a la última fila con datos, eliminando las filas que se encuentren duplicadas.

En este playlist se muestran diferentes maneras de Eliminar Filas de Excel en Base a Criterios.

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.





 


El ejemplo que se presenta es bastante sencillo, toma una columna determinada que en este caso es la Columna D de la Hoja1, verificando si los datos o la palabra contenida en cada celda está duplicada en el resto de celdas de la misma columna en caso afirmativo borra todas la filas duplicadas, dejando solamente datos únicos o sin duplicar.

En primer momento se determina la última fila con datos, para ello se usa el siguiente código:

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

El código anterior permite determinar la última fila con datos, si requieres aprender mas sobre como determinar la última fila con dato haz clic en los siguientes links, como determinar la última fila con datos, como determinar la última fila con datos de una selección, como determinar la última fila con datos de un rango con filas vacías entre medio.

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

Como Repetir un Mismo Caracter Varias Veces en Excel

Como Buscar Archivos en un Directorio y Hacer Link al Ficheros

Como eliminar el Boton X o Cerrar de un Formulario


Con el siguiente código se podrán eliminar los duplicados de las Hojas de Excel:

a.Range("A1:G" & uf).RemoveDuplicates Columns:=4, Header:=xlYes


En primer lugar se determina donde se encuentran los datos, es decir el rango, para ello se determinó previamente cual era la última fila con datos, para ello se determinó cual era la última fila con datos, lo cual permite establecer un rango dinámico, es decir por más que se sigan agregando filas el rango se determinará automáticamente.

Al rango de datos se aplica el código que permite eliminar duplicados, entre los parámetros que se deben ingresar es donde se encuentra la columna, que permite determinar el criterio de duplicidad, en otras palabras se le debe decir a la macro, que criterio seguir para determinar si un dato es duplicado o no, en este ejemplo el criterio de duplicidad son todas las palabras iguales que estén en la Columa 4 o "D", en el código anterior se le indica que la columna D tiene encabezado por ende no tendrá en cuenta la primer fila.

El código completo está a continuación y posteriormente el link de descarga del archivo Excel de ejemplo denominado Como Eliminar Datos Duplicados en Excel.

Código que se inserta en un módulo

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

Sub EliminaDuplicado()

Application.ScreenUpdating = False

On Error Resume Next

Set a = Sheets("Hoja1")

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

a.Range("A1:G" & uf).RemoveDuplicates Columns:=4, Header:=xlYes

MsgBox ("Los datos se elimnaron se éxito"), vbInformation, "AVISO"

Application.ScreenUpdating = True

End Sub


Sub DeNuevo()

Set a = Sheets("Hoja1")

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

a.Range("A1:G" & uf).Clear

Sheets("Hoja2").Range("A:G").Copy Destination:=a.Range("A1")

MsgBox ("Se copio la base de datos nuevamente"), vbInformation, "AVISO"

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 Exportar Desde Excel y Guardar Archivo TXT con Ancho Fijo Rellenando Campos con Barra Inclinada






En este ejemplo de macro se muestra como Exportar de Excel a un Archivo TXT Delimitado con Acho Fijo, Rellenando Campo con Barras; es decir la macro crea un archivo TXT con la información contenida en la hoja de Excel, los campos del archivo de texto plano estarán delimitados o separados por un ancho fijo de cada campo y el campo se rrellenará con barras inclinadas en caso de que los caracteres del campo sean menores al ancho fijo establecido.

Quieres aprender más sobre como importar exportar archivos de Excel a TXT o TXT a Excel, mira el siguiente playlist donde encontrarás muchos ejemplos.

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.






 


La macro en un primer lugar crea el nombre del archivo TXT para eso determina el nombre del archivo actual que es el que contiene la macro, para denominar el fichero TXT a crear con el nombre del archivo actual, pero con extensión TXT, usa los siguientes códigos:

nom = ActiveWorkbook.Name

pto = InStr(nom, ".")

nomarch = Left(nom, pto - 1)

myfile = ThisWorkbook.Path & "\" & nomarch & ".txt"

Luego establece cual va a ser el largo de cada campo, establece el largo de todos los campos a exportarse a TX, ello se hace con la siguiente codificación:

larC1 = 5

larC2 = 10

larC3 = 50

larC4 = 50

larC5 = 15

larC6 = 10

larC7 = 15

Las variables anteriores establecen cual va a ser el ancho fijo de cada columna y lo carga en cada unas de las variables, esto es lo que se debe modificar para establecer la cantidad de caracteres o ancho de campo, pudiendo agregar más variables en el caso de tener más columnas a Exportar a TXT.

Con las siguientes variables se va a establecer cual va a ser el caracter que se va a usar para rellenar los campos en caso que la cantidad de texto de las palabras o string que hayan en cada celda sea menor al ancho fijo de caracteres, si la cantidad de caracteres de la celda  es menor rellena con barra inclinada (/), si es igual no hace nada y si es mayor va a truncar o cortar los caracteres acortándolos al ancho dado en las variables destinadas a tal fin.

cara = "/" 'caracter para completar el espacio

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

Como crear una factura con excel, guardarla y enviarla por mail automáticamente


Como enviar mail con archivo Excel y PDF mediante Outlook con Excel

Como hacer un link o hiperlink a google maps con Excel

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



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

Con el siguiente código se determinar la última fila con datos para realizar un bucle y se crea el archivo TXT :

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

Open myfile For Output As #1


Luego se realiza un bucle de la primer a la última fila con datos exportando los datos de Excel a TXT, de la siguiente forma:

For i = 2 To uf

C1 = String(larC1 - Len(Cells(i, 1)), cara) & Cells(i, 1)

C2 = String(larC2 - Len(Cells(i, 2)), cara) & Cells(i, 2)

C3 = Cells(i, 3) & String(larC3 - Len(Cells(i, 3)), cara)

C4 = Cells(i, 4) & String(larC4 - Len(Cells(i, 4)), cara)

C5 = String(larC5 - Len(Cells(i, 5)), cara) & Cells(i, 5)

C6 = String(larC6 - Len(Cells(i, 6)), cara) & Cells(i, 6)

C7 = String(larC7 - Len(Cells(i, 7)), cara) & Cells(i, 7)

Print #1, C1 & C2 & C3 & C4 & C5 & C6 & C7

Next i

Se debe destacar que se crea una variable por cada columna a exportar utilizando una función de VBA para repetir un caracteres en este caso la barra inclinada, cuantas veces se repetirá dependerá de la diferencia entre el largo del campo y el largo del texto de cada ceda, con el siguiente código se logra repetir la cantidad de caracteres necesarios para rellenar el campo: 

 String(larC1 - Len(Cells(i, 1)), cara)

Luego se concatena los datos repetidos con el dato de cada celda recorrida por el bucle, dando origen a las variables C1, C2...Cn.

A medida que el bucle recorre cada celda va agregando los datos el archivo TXT, con la siguiente codificación:

Print #1, C1 & C2 & C3 & C4 & C5 & C6 & C7


El ejemplo denominado como Exportar Datos Desde Excel a TXT Delimitado por Ancho Fijo Rellenando Campos con Barra Inclinada, se puede descargar desde el link del final y seguidamente se muestra la codificación entera del ejemplo, el cual contiene los códigos necesarios al principio para hacerlo compatible en entornos de 32 o 64 Bits.


Código que se inserta en un módulo

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


Sub ExportaTXTAnchoFijoRellenoBarra()

Dim i As Double

'On Error Resume Next

Set a = Sheets("Hoja1")

nom = ActiveWorkbook.Name

pto = InStr(nom, ".")

nomarch = Left(nom, pto - 1)

myfile = ThisWorkbook.Path & "\" & nomarch & ".txt"

'largo de campos

larC1 = 5

larC2 = 10

larC3 = 50

larC4 = 50

larC5 = 15

larC6 = 10

larC7 = 15

cara = "/" 'caracter para completar el espacio

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


Open myfile For Output As #1

For i = 2 To uf

C1 = String(larC1 - Len(Cells(i, 1)), cara) & Cells(i, 1)

C2 = String(larC2 - Len(Cells(i, 2)), cara) & Cells(i, 2)

C3 = Cells(i, 3) & String(larC3 - Len(Cells(i, 3)), cara)

C4 = Cells(i, 4) & String(larC4 - Len(Cells(i, 4)), cara)

C5 = String(larC5 - Len(Cells(i, 5)), cara) & Cells(i, 5)

C6 = String(larC6 - Len(Cells(i, 6)), cara) & Cells(i, 6)

C7 = String(larC7 - Len(Cells(i, 7)), cara) & Cells(i, 7)

Print #1, C1 & C2 & C3 & C4 & C5 & C6 & C7

Next i

Close

MsgBox ("El archivo txt se creo con éxito"), vbInformation, "AVISO"

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 Eliminar Item al Pasar Datos Listbox a Otro y Guardar






En este post se muestra algo solicitado en nuestro canal de YouTube, es una Macro que Pasa Datos de un Listbox a Otro y Guarda en Hoja Excel, es otras palabras se muestra como haciendo doble click se pasa un elemento del listbox a otro listbox, a su vez guarda en la hoja correspondiente eliminando el item de la base de datos que da origen al primer listbox.

Si estás trabajando con listbox quizás quieras aprender más sobre este objeto de VBA para Excel, en el link encontrarás muchos ejemplos que serán de utilidad relacionados con listbox de 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 que sea más fácil de entender recomiendo descargar el ejemplo, desde el link del final se podrá hacer dicha descarga, el ejemplo muestra como al hacer doble click en en el Listbox1 que es el que tiene fondo blanco, se pasa el item al Listbox2 que tiene fondo celeste.

A la vez que se pasan los datos de un Listbox a Otro Listbox, también se borra de la Hoja1 de Excel que sirve de base de datos para el Listbox1, guardando el dato en la Hoja2 que es la base de datos del Listbox1.

Básicamente la programación del Listbox2 es idéntica a la del Listbox1, solo que Intercambia donde debe copiar y eliminar datos tanto del listbox como de la hoja de Excel que es donde están contenidos los datos que se muestran en el mismo, es por ello que solo se explicará sobre que realiza la macro en el Listbox1 quedando como tarea para los lectores replicar la misma macro, pero en el Listbox2, no obstante el código que se expone está en forma completa para los dos Listbox.


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

Como Exportar desde Excel a TXT de Ancho Fijo


Como Espaciar los Registros en Listbox de Excel

Como Buscar por Cliente Rango de Fechas y Totalizar en el Listbox



Para lograr realizar lo mencionado en el ejemplo se debe primero pasar los datos del Listbox1 al Listbox2, lo cual se logra con los siguientes códigos:

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)

También se debe guardar el dato correspondiente en la Hoja2 para ello se usan estos códigos

filaedit = c.Range("A" & Rows.Count).End(xlUp).Row + 1
c.Cells(filaedit, "A") = a.List(fila, 0)
c.Cells(filaedit, "B") = a.List(fila, 1)
c.Cells(filaedit, "C") = a.List(fila, 2)
c.Cells(filaedit, "D") = a.List(fila, 3)


Luego se ordenan los datos en la Hoja2 así:

uf = c.Range("A" & Rows.Count).End(xlUp).Row
r1 = "A1:D" & uf
r2 = "A1:A" & uf
c.Sort.SortFields.Clear
c.Sort.SortFields.Add Key:=Range(r2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With c.Sort
.SetRange Range(r1)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With


Luego se busca en la Hoja1 el item correspondiente para eliminarlo, ya que fue guardado en la Hoja2, se usan los siguienes códigos:

uf = d.Range("A" & Rows.Count).End(xlUp).Row
r1 = "A2:A" & uf
busco = a.List(fila, 0)
Set codigo = Range(r1).Find(busco, LookIn:=xlValues, LookAt:=xlWhole)
If Not codigo Is Nothing Then d.Cells(codigo.Row, "A").EntireRow.Delete
a.RemoveItem a.ListIndex
End Sub

Se debe tener presente que se tiene que eliminar el item del Listbox1, para ello se usa el siguiente código:

a.RemoveItem a.ListIndex

En resumen, la macro copia del Listbox1 al Listbox2, copia inmediatamente los registos en la Hoja2, a la vez que busca el mismo dato en la Hoja 1 para elimiarlo, por último elimina el item en el Listbo1; el código completo del Ejemplo de macro llamado Como Eliminar Item al Pasar Datos Listox a Otro Listbox y Guardar Datos en Excel se muestra a continuación y seguidamente se encuentra el link para descarga del ejemplo.


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
Set c = Sheets("Hoja2")
Set d = Sheets("Hoja1")
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)

filaedit = c.Range("A" & Rows.Count).End(xlUp).Row + 1
c.Cells(filaedit, "A") = a.List(fila, 0)
c.Cells(filaedit, "B") = a.List(fila, 1)
c.Cells(filaedit, "C") = a.List(fila, 2)
c.Cells(filaedit, "D") = a.List(fila, 3)

uf = c.Range("A" & Rows.Count).End(xlUp).Row
r1 = "A1:D" & uf
r2 = "A1:A" & uf
c.Sort.SortFields.Clear
c.Sort.SortFields.Add Key:=Range(r2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With c.Sort
.SetRange Range(r1)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

uf = d.Range("A" & Rows.Count).End(xlUp).Row
r1 = "A2:A" & uf
busco = a.List(fila, 0)
Set codigo = Range(r1).Find(busco, LookIn:=xlValues, LookAt:=xlWhole)
If Not codigo Is Nothing Then d.Cells(codigo.Row, "A").EntireRow.Delete
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
Set cc = Sheets("Hoja2")
Set dd = Sheets("Hoja1")

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)

filaedit = dd.Range("A" & Rows.Count).End(xlUp).Row + 1
dd.Cells(filaedit, "A") = bb.List(fila, 0)
dd.Cells(filaedit, "B") = bb.List(fila, 1)
dd.Cells(filaedit, "C") = bb.List(fila, 2)
dd.Cells(filaedit, "D") = bb.List(fila, 3)


uf = dd.Range("A" & Rows.Count).End(xlUp).Row
r1 = "A1:D" & uf
r2 = "A1:A" & uf
dd.Sort.SortFields.Clear
dd.Sort.SortFields.Add Key:=Range(r2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With dd.Sort
.SetRange Range(r1)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

uf = cc.Range("A" & Rows.Count).End(xlUp).Row
r1 = "A2:A" & uf
busco = bb.List(fila, 0)
Set codigo = cc.Range(r1).Find(busco, LookIn:=xlValues, LookAt:=xlWhole)
If Not codigo Is Nothing Then cc.Cells(codigo.Row, "A").EntireRow.Delete
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 a = Sheets("Hoja1")
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

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


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.ListBox2.AddItem b.Cells(i, 1)
       Me.ListBox2.List(Me.ListBox2.ListCount - 1, 1) = b.Cells(i, 2)
       Me.ListBox2.List(Me.ListBox2.ListCount - 1, 2) = b.Cells(i, 3)
       Me.ListBox2.List(Me.ListBox2.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