PROGRAMAR EN VBA MACROS PARA EXCEL: octubre 2018

Como Exportar Desde Excel a TXT con Ancho Fijo






En este post se muestra Como Exportar de Excel a TXT Delimitando Registros con Ancho Fijo, es decir se generará un archivo plano con todos los datos que hayamos exportado de Excel al TXT.

Para ver más tutoriales sobre exportación importación de datos de Excel a TXT debes seguir el siguiente link

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 permite exportar dos datos contenidos en la hoja de Excel a un Archivo TXT, pero delimitados o separados los registros entre sí por un ancho fijo, normalmente los sistemas informáticos cuando importan o exportan datos tienen un ancho determinado de caracteres para cada campo, bien en este ejemplo se crea un TXT con se ancho predeterminado de campo.

La macro crea un archivo TXT que lleva el mismo nombre que el archivo con la macro, pero con extensión TXT, eso se crea con los códigos que se muestran a continuación:

nom = ActiveWorkbook.Name
pto = InStr(nom, ".")
nomarch = Left(nom, pto - 1)
myfile = ThisWorkbook.Path & "\" & nomarch & ".txt"

Ahora la macro establece cual va a ser el ancho de cada campo, llamamos campo a cada columna de la hoja de Excel, se crea con los siguientes códigos:

larC1 = 5
larC2 = 10
larC3 = 50
larC4 = 50
larC5 = 15
larC6 = 10
larC7 = 15

Luego asignamos a la variable cara cual va a ser el caracter que delimitará los registros, en este ejemplo el caracter para completar los espacios faltantes para llegar al largo de cada campo, es un espacio en blanco, se usa el siguiente código:

cara = " " 'caracter para completar el espacio


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

Como cargar listbox de más de diez columnas

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

Como hacer un link o hiperlink a google maps con Excel

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



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

Luego la macro realiza un bucle entre la primer y la última fila con datos, cuyas filas de Excel va a ir recorriendo y exportando a TXT.

Para agregar los espacios en blanco necesarios para que se cumpla el largo del campo, se hace una resta entre el largo establecido del campo menos el largo de los registros, agregando el caracter en blanco a los espacios faltantes para completar el largo del campo.

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

Luego de determinar cada registro se concatena todos los registros de la columnas y fila que recorre el bucle en cada momentos, luego exporta dicho registro a TXT. Lo mencionado se hace con el siguiente código:

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

El ejemplo Como Exportar Desde Excel a TXT con ancho fijo, se puede descargar desde el link del final, a continuación la codificación completa.


Código que se inserta en un Formulario 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

Sub ExportaTXTAnchoFijoRellenoEspacios()
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 Filtrar por Cliente Rango de Fechas y Exportar a PDF






En este ejemplo se mostrará Como Filtrar Datos por Cliente y/o Rango de Fechas y Exportar Datos a PDF, es decir en el formulario se podrá filtrar datos por clientes o rango de fechas o también por cliente y luego sumarle al filtro que se seleccione los datos entre una fecha inicial y una final, obtenidos los datos se cargarán en el listbox pudiendo luego con los datos que están filtrados y fueron mostrados en el listbox exportarlos a PDF.

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.







 


Sugiero descargar el ejemplo para que sea más fácil de comprender, resumiendo la macro contenida en el formulario de Excel y en los botones insertos, permiten realizar filtros por cliente que también puede ser proveedor, una marca o cualquier dato, cada uno lo puede adaptar.

Al filtro por cliente si se quiere se puede adicionar un filtro por un rango de fechas, estos datos obtenidos se mostrarán en el Listbox inserto en el formulario , existiendo un botón que permite Exportar los datos filtrados a PDF.

La macro que filtra por cliente y rango de fechas se puede consultar en el siguiente link, una de ellas hay varios ejemplos los cuales se pueden encontrar en el siguiente playlist Listbox de Excel.

En este post nos vamos a detener en mostrar como se puede exportar a PDF los datos ya filtrados, ya que como se hace el filtro por fecha y cliente ya fue explicado anteriormente, la macro para exportar a PDF se encuentre en el CommandButton4, que en el formulario tiene un icono con imagen que dice PDF.

Para lograr lo mencionado se procederá a crear una hoja temporal de Excel, primero en caso que exista se borra la hoja luego se inserta una una y se le asigna nombre creando un objeto con dicha hoja, con los siguientes códigos:

Sheets("DFSHJFDUYDAYRAIUY544TTTOMYDUTGD").Delete
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "DFSHJFDUYDAYRAIUY544TTTOMYDUTGD"
Set a = Sheets("DFSHJFDUYDAYRAIUY544TTTOMYDUTGD")

Luego se copian todos los datos filtrados que se están mostrando en el Userform en la hoja temporal que se ha creado, para ello se realiza un bucle entre la primer y ultima fila del listbox, pasando los datos a la hoja temporal, apelando a los siguientes códigos:

For x = 1 To UserForm1.ListBox1.ListCount - 5
a.Cells(x + 2, "A") = ListBox1.List(x, 0)
a.Cells(x + 2, "B") = CDate(ListBox1.List(x, 1))
a.Cells(x + 2, "C") = ListBox1.List(x, 2)
a.Cells(x + 2, "D") = ListBox1.List(x, 3)
a.Cells(x + 2, "E") = ListBox1.List(x, 4)
a.Cells(x + 2, "F") = ListBox1.List(x, 5)
a.Cells(x + 2, "G") = CDec(ListBox1.List(x, 6))
Next


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

Como filtrar datos llenar listbox de más de diez columnas


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

Como agregar menu ayuda en iconos personalizados barra Ribbon o Cinta Opciones Excel


Posteriormente se de la un formato al informe, le he dado ancho de columnas, formato fecha, ajuste a una pagina de alto y ancho, etc, cada uno dará el formato que necesite en su proyecto, he aplicado los siguientes códigos:

With a.Range("A1:G1")
.Merge 'Combinación celdas A a G
.VerticalAlignment = xlCenter 'Alineación Vertical Centrada
.HorizontalAlignment = xlCenter 'Alineación Horizontal Centrada
.RowHeight = 20 'Alto Fila
.Font.Size = 16 'Tamaño Fuente
End With

a.Range("A2") = "CLIENTE"  'Crea los encabezados de las columnas
a.Range("B2") = "FECHA"
a.Range("C2") = "COMPROBANTE"
a.Range("D2") = "TIPO"
a.Range("E2") = "SUC"
a.Range("F2") = "N COMP"
a.Range("G2") = "IMPORTE"
uf = a.Range("G" & Rows.Count).End(xlUp).Row
a.Range("G2:G" & uf).NumberFormat = "#.#,0"  'formato númerico con dos decimales
a.Range("B2:B" & uf).NumberFormat = "dd/mm/yyyy" 'formato fecha ejemplo 12/06/2014
a.Range("A:G").Columns.AutoFit 'Ajuste automático de la columna al texto
a.Range("A:A").ColumnWidth = 31 'Ancho de columna
Application.PrintCommunication = True
With ActiveSheet.PageSetup
.PrintArea = "$A$1:$G$" & uf + 4 'Crea área de impresión
.FitToPagesWide = 1   'Ajuste de alto y ancho de páginas
.FitToPagesTall = 1
End With

Luego la macro procede a crear el nombre con el que se guardará el fichero PDF, tomando el nombre del archivo que contiene la macro más la extensión PDG, así:

nom = ActiveWorkbook.Name
pto = InStr(nom, ".")
nomarch = Left(nom, pto - 1)
'nomarch = nomarch & ".pdf"
myfile = ThisWorkbook.Path & "\" & nomarch

El paso siguiente es exportar a PDF con el siguiente código:

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=myfile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

Por último borra la hoja temporal y sale un mensaje avisando de la exportación de los datos a un archivo a PDF, con la siguiente codificación:

a.Delete 'Es para borrar la hoja temporar creada
Sheets("Hoja1").Select 'selecciona la hoja 1
MsgBox "El reporte se exportó a PDF con éxito", vbCritical, "AVISO" 'emite aviso

Con esto damos por finalizada la explicación del ejemplo que permite Filtrar por Cliente Rango de Fechas y Exportar a PDF los Datos Filtrados, a continuación la codificación completa y posteriormente el link de descar de ejemplo que es como siempre absolutamente gratis.


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 CommandButton2_Click()
On Error Resume Next
Set b = Sheets("Hoja1")
uf = b.Range("A" & Rows.Count).End(xlUp).Row
dato1 = CDate(TextBox2)
dato2 = CDate(TextBox3)
If dato2 = Empty Or dato1 = emtpy Then
MsgBox ("Debe ingresar datos para consulta entre rango de fechas"), vbCritical, "AVISO"
Exit Sub
End If
If dato2 < dato1 Then
MsgBox ("La fecha final no puede ser mayor a la fecha inicial"), vbCritical, "AVISO"
Exit Sub
End If

b.AutoFilterMode = False
Me.ListBox1 = Clear
Me.ListBox1.RowSource = Clear

'Adiciona un item al listbox reservado para la cabecera
UserForm1.ListBox1.AddItem

If dato1 = Empty Or dato2 = Empty Then

For i = 2 To uf
   dato0 = CDate(b.Cells(i, 2).Value)
   If dato0 >= dato1 And dato0 <= dato2 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)
   End If
Next i


Else

If dato2 < dato1 Then
MsgBox ("La fecha final no puede ser mayor a la fecha inicial"), vbCritical, "AVISO"
Exit Sub
End If

For i = 2 To uf
   strg = b.Cells(i, 1).Value
   dato0 = CDate(b.Cells(i, 2).Value)
   If UCase(strg) Like UCase(TextBox1.Value) & "*" And dato0 >= dato1 And dato0 <= dato2 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)
   End If
Next i

End If


'Carga los datos de la cabecera en listbox
For ii = 0 To 7
UserForm1.ListBox1.List(0, ii) = Sheets("Hoja1").Cells(1, ii + 1)
Next ii

UserForm1.ListBox1.AddItem
UserForm1.ListBox1.AddItem
UserForm1.ListBox1.AddItem
UserForm1.ListBox1.List(UserForm1.ListBox1.ListCount - 1, 0) = "Total Importe"

For x = 0 To UserForm1.ListBox1.ListCount - 1
t = CDec(UserForm1.ListBox1.List(x, 6))
tot = tot + t
t = 0
Next x
UserForm1.ListBox1.List(UserForm1.ListBox1.ListCount - 1, 1) = Format(tot, " ""U$S"" #,##0.00 ")

UserForm1.ListBox1.AddItem
UserForm1.ListBox1.List(UserForm1.ListBox1.ListCount - 1, 0) = "Total de registros:"
UserForm1.ListBox1.List(UserForm1.ListBox1.ListCount - 1, 1) = UserForm1.ListBox1.ListCount - 5

Me.ListBox1.ColumnWidths = "170 pt;70 pt;50 pt;50 pt;50 pt;50 pt;50 pt"
End Sub

Private Sub CommandButton3_Click()
Unload UserForm1
End Sub

Private Sub CommandButton4_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next

'Elimina hoja y crea hoja dando el mismo nombre que la eliminada
Sheets("DFSHJFDUYDAYRAIUY544TTTOMYDUTGD").Delete
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "DFSHJFDUYDAYRAIUY544TTTOMYDUTGD"
Set a = Sheets("DFSHJFDUYDAYRAIUY544TTTOMYDUTGD")

For x = 1 To UserForm1.ListBox1.ListCount - 5
a.Cells(x + 2, "A") = ListBox1.List(x, 0)
a.Cells(x + 2, "B") = CDate(ListBox1.List(x, 1))
a.Cells(x + 2, "C") = ListBox1.List(x, 2)
a.Cells(x + 2, "D") = ListBox1.List(x, 3)
a.Cells(x + 2, "E") = ListBox1.List(x, 4)
a.Cells(x + 2, "F") = ListBox1.List(x, 5)
a.Cells(x + 2, "G") = CDec(ListBox1.List(x, 6))
Next

a.Cells(x + 4, "A") = ListBox1.List(x + 2, 0)
a.Cells(x + 5, "A") = ListBox1.List(x + 3, 0)
a.Cells(x + 4, "B") = ListBox1.List(x + 2, 1)
a.Cells(x + 5, "B") = ListBox1.List(x + 3, 1)

a.Activate
a.Range("A1") = "REPORTE DE VENTAS"

With a.Range("A1:G1")
.Merge
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.RowHeight = 20
.Font.Size = 16
End With

a.Range("A2") = "CLIENTE"
a.Range("B2") = "FECHA"
a.Range("C2") = "COMPROBANTE"
a.Range("D2") = "TIPO"
a.Range("E2") = "SUC"
a.Range("F2") = "N COMP"
a.Range("G2") = "IMPORTE"
uf = a.Range("G" & Rows.Count).End(xlUp).Row
a.Range("G2:G" & uf).NumberFormat = "#.#,0"
a.Range("B2:B" & uf).NumberFormat = "dd/mm/yyyy"
a.Range("A:G").Columns.AutoFit
a.Range("A:A").ColumnWidth = 31
Application.PrintCommunication = True
With ActiveSheet.PageSetup
.PrintArea = "$A$1:$G$" & uf + 4
.FitToPagesWide = 1
.FitToPagesTall = 1
End With


nom = ActiveWorkbook.Name
pto = InStr(nom, ".")
nomarch = Left(nom, pto - 1)
'nomarch = nomarch & ".pdf"
myfile = ThisWorkbook.Path & "\" & nomarch

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=myfile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

a.Delete
Sheets("Hoja1").Select
MsgBox "El reporte se exportó a PDF con éxito", vbCritical, "AVISO"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
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.RowSource = "Hoja1!A1:G" & uf
   Exit Sub
End If


b.AutoFilterMode = False
Me.ListBox1 = Clear
Me.ListBox1.RowSource = Clear
dato1 = CDate(TextBox2)
dato2 = CDate(TextBox3)
'Adiciona un item al listbox reservado para la cabecera
UserForm1.ListBox1.AddItem


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)
       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)
   End If
Next i



'Carga los datos de la cabecera en listbox
For ii = 0 To 7
UserForm1.ListBox1.List(0, ii) = Sheets("Hoja1").Cells(1, ii + 1)
Next ii


UserForm1.ListBox1.AddItem
UserForm1.ListBox1.AddItem
UserForm1.ListBox1.AddItem
UserForm1.ListBox1.List(UserForm1.ListBox1.ListCount - 1, 0) = "Total Importe"

For x = 0 To UserForm1.ListBox1.ListCount - 1
t = CDec(UserForm1.ListBox1.List(x, 6))
tot = tot + t
t = 0
Next x
UserForm1.ListBox1.List(UserForm1.ListBox1.ListCount - 1, 1) = Format(tot, " ""U$S"" #,##0.00 ")

UserForm1.ListBox1.AddItem
UserForm1.ListBox1.List(UserForm1.ListBox1.ListCount - 1, 0) = "Total de registros:"
UserForm1.ListBox1.List(UserForm1.ListBox1.ListCount - 1, 1) = UserForm1.ListBox1.ListCount - 5


UserForm1.TextBox2 = Clear
UserForm1.TextBox3 = Clear

Me.ListBox1.ColumnWidths = "170 pt;70 pt;50 pt;50 pt;50 pt;50 pt;50 pt"
End Sub

Private Sub TextBox2_Change()
If Len(UserForm1.TextBox2) = 10 Then UserForm1.TextBox3.SetFocus
End Sub

Private Sub TextBox3_Change()
If Len(UserForm1.TextBox3) = 10 Then UserForm1.CommandButton2.SetFocus
End Sub

Private Sub UserForm_Initialize()
Dim fila As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set b = Sheets("Hoja1")
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 = 7
    .ColumnWidths = "170 pt;50 pt;50 pt;50 pt;50 pt;50 pt;50 pt"
    .RowSource = "Hoja1!A1:" & wc & uf
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error GoTo Fin
If CloseMode <> 1 Then Cancel = True
Fin:
End Sub

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 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 Cargar o Llenar Listbox Excel con Mas de Diez Columnas






Hoy presentamos un ejemplo solicitado por un suscriptor de nuestro canal de YouTube, el cual requerida saber Como Llenar un Listbox Con Mas de Diez Columnas, precisamente eso hace esta macro, rellena Listbox donde se requieren cargar en el Listbox más de 10 columnas.

Como es sabido los listbox de Excel solo admiten 10 columnas, pero tranquilos, existe la posibilidad de cargar más de diez columnas en el listbox, ya que muchas veces es preciso tener una cantidad mayor al límite del 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 y activa la campanita 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 ejemplo y abrir el libro Excel se observa un botón que permite mostrar un formulario, en dicho formulario se puede filtrar por cliente o rango de fecha, pero eso no es motivo de este post, (si requieres saber como filtrar por cliente y fecha haz click en el link), lo interesante es que al filtrar se pueden cargar más de diez columnas al listbox.

Ya se ha explicado que para poder cargar más de 10 columnas en un listbox de Excel se necesita usar el método RowSource ya que el método AddItem, solo permite cargar en el listbox solamente hasta diez columnas, mientras que con RowSource se pueden rellenar un listbox con muchas más columnas, que las previstas con el método AddItem.

Cuando se inicia el formulario no hay problema, porque establecemos cual es el origen de los datos y se carga en el listbox, con el siguiente código

  .RowSource = "Hoja1!A1:" & wc & uf


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

Como LLenar Combobox y Buscar Datos


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

Como rellenar un pagaré en forma automática Conectar Excel con Word

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



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

Para proceder a cargar más de diez columnas en un listbox de Excel, vamos a apoyarnos en una hoja de Excel Temporal, es decir la vamos a insertar vamos a guardar los datos filtrados en ella, vamos a establecer el origen de los datos o RowSurce, cargando los resultados del filtro al listbox y por último elimina la hoja temporal, mostrándose en el listbox más de 10 columnas.

La macro en primer lugar va a eliminar una hoja cuyo nombre hemos dado con la macro, posterior a ello inserta una hoja de excel y se otorga el nombre predeterminado, creando luego un objeto con esta hoja, ello se hace con los siguientes códigos:

heets("DFSHJFDUYDAYRAIUY544TTTOMYDUTGD").Delete
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "DFSHJFDUYDAYRAIUY544TTTOMYDUTGD"
Set a = Sheets("DFSHJFDUYDAYRAIUY544TTTOMYDUTGD")

Luego se procede a realizar el filtro ya sea por cliente, por rango de fechas, una vez que la macro encontró cuales son los datos coincidentes con el criterio de búsqueda, en vez de cargados los datos filtrados en el listbox, ya que la base de datos tiene más de 10 columnas, procedemos a guardarlos temporalmente en la hoja de Excel que se ha creado a tal fin.

Para filtrar los datos ya sea por cliente o rango de fechas y guardar temporalmente en le hoja Excel se usa el siguiente fragmento de código


For i = 2 To uf
   strg = b.Cells(i, 3).Value
   dato0 = CDate(b.Cells(i, 4).Value)
   If UCase(strg) Like UCase(TextBox1.Value) & "*" And dato0 >= dato1 And dato0 <= dato2 Then
       a.Cells(fila, 1) = b.Cells(i, 1)
       a.Cells(fila, 2) = b.Cells(i, 2)
       a.Cells(fila, 3) = b.Cells(i, 3)
       a.Cells(fila, 4) = b.Cells(i, 4)
       a.Cells(fila, 5) = b.Cells(i, 5)
       a.Cells(fila, 6) = b.Cells(i, 6)
       a.Cells(fila, 7) = b.Cells(i, 7)
       a.Cells(fila, 8) = b.Cells(i, 8)
       a.Cells(fila, 9) = b.Cells(i, 9)
       a.Cells(fila, 10) = b.Cells(i, 10)
       a.Cells(fila, 11) = b.Cells(i, 11)
       a.Cells(fila, 12) = b.Cells(i, 12)
       fila = fila + 1

   End If
Next i


Una vez filtrados los datos y guardados en la hoja temporal se procede a modificar mediante código las propiedades del listbox, en este caso se le otorga una cantidad de 12 columnas, como así también el ancho de cada columna, por último y los más importante se establece el origen de datos o RowSource, de la siguiente manera:

With Me.ListBox1
    .ColumnCount = 12
    .ColumnWidths = "20 pt; 15pt; 170 pt;50 pt;50 pt;50 pt;50 pt;50 pt;50 pt;50 pt;50 pt;50 pt"
    .RowSource = "DFSHJFDUYDAYRAIUY544TTTOMYDUTGD!A1:" & wc & uf
End With


Para finalizar la macro se elimina la hoja, luego de haber cargado los datos en el listbbox de Excel, todo lo mencionado sucede en forma casi instantánea, para evitar movimientos de pantalla se debe usar el siguiente código:

Application.ScreenUpdating = False


En el vídeo encontrarás un tutorial con una explicación más detallada, por lo que sugiero ver el tutorial denominado Como Rellenar Listbox de Excel con más de 10 Columnas, seguidamente se muestra el código completo y en forma posterior están los link de descargas.


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 CommandButton2_Click()
On Error Resume Next
Set b = Sheets("Hoja1")
uf = b.Range("A" & Rows.Count).End(xlUp).Row
dato1 = CDate(TextBox2)
dato2 = CDate(TextBox3)
If dato2 = Empty Or dato1 = emtpy Then
MsgBox ("Debe ingresar datos para consulta entre rango de fechas"), vbCritical, "AVISO"
Exit Sub
End If
If dato2 < dato1 Then
MsgBox ("La fecha final no puede ser mayor a la fecha inicial"), vbCritical, "AVISO"
Exit Sub
End If

b.AutoFilterMode = False
Me.ListBox1 = Clear
Me.ListBox1.RowSource = Clear

'Elimina hoja y crea hoja dando el mismo nombre que la eliminada
Sheets("DFSHJFDUYDAYRAIUY544TTTOMYDUTGD").Delete
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "DFSHJFDUYDAYRAIUY544TTTOMYDUTGD"
Set a = Sheets("DFSHJFDUYDAYRAIUY544TTTOMYDUTGD")
b.Range("A1:L1").Copy Destination:=a.Range("A1")
fila = 2

If dato2 < dato1 Then
MsgBox ("La fecha final no puede ser mayor a la fecha inicial"), vbCritical, "AVISO"
Exit Sub
End If

For i = 2 To uf
   strg = b.Cells(i, 3).Value
   dato0 = CDate(b.Cells(i, 4).Value)
   If UCase(strg) Like UCase(TextBox1.Value) & "*" And dato0 >= dato1 And dato0 <= dato2 Then
       a.Cells(fila, 1) = b.Cells(i, 1)
       a.Cells(fila, 2) = b.Cells(i, 2)
       a.Cells(fila, 3) = b.Cells(i, 3)
       a.Cells(fila, 4) = b.Cells(i, 4)
       a.Cells(fila, 5) = b.Cells(i, 5)
       a.Cells(fila, 6) = b.Cells(i, 6)
       a.Cells(fila, 7) = b.Cells(i, 7)
       a.Cells(fila, 8) = b.Cells(i, 8)
       a.Cells(fila, 9) = b.Cells(i, 9)
       a.Cells(fila, 10) = b.Cells(i, 10)
       a.Cells(fila, 11) = b.Cells(i, 11)
       a.Cells(fila, 12) = b.Cells(i, 12)
       fila = fila + 1

   End If
Next i


a.Range("D:G").NumberFormat = "dd/mm/yyyy"

uf = a.Range("A" & Rows.Count).End(xlUp).Row
uc = a.Cells(1, Columns.Count).End(xlToLeft).Address
wc = Mid(uc, InStr(uc, "$") + 1, InStr(2, uc, "$") - 2)
With Me.ListBox1
    .ColumnCount = 12
    .ColumnWidths = "20 pt; 15pt; 170 pt;50 pt;50 pt;50 pt;50 pt;50 pt;50 pt;50 pt;50 pt;50 pt"
    .RowSource = "DFSHJFDUYDAYRAIUY544TTTOMYDUTGD!A1:" & wc & uf
End With

a.Delete
End Sub

Private Sub CommandButton3_Click()
Unload UserForm1
End Sub

Private Sub TextBox1_Change()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
On Error Resume Next
Set b = Sheets("Hoja1")
uf = b.Range("A" & Rows.Count).End(xlUp).Row
If Trim(TextBox1.Value) = "" Then
   Me.ListBox1.RowSource = "Hoja1!A1:L" & uf
   Me.ListBox1.ColumnCount = 12
   Me.ListBox1.ColumnWidths = "20 pt; 15pt; 170 pt;50 pt;50 pt;50 pt;50 pt;50 pt;50 pt;50 pt;50 pt;50 pt"
   Exit Sub
End If


b.AutoFilterMode = False
Me.ListBox1 = Clear
Me.ListBox1.RowSource = Clear
dato1 = CDate(TextBox2)
dato2 = CDate(TextBox3)

'Elimina hoja y crea hoja dando el mismo nombre que la eliminada
Sheets("DFSHJFDUYDAYRAIUY544TTTOMYDUTGD").Delete
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "DFSHJFDUYDAYRAIUY544TTTOMYDUTGD"
Set a = Sheets("DFSHJFDUYDAYRAIUY544TTTOMYDUTGD")
b.Range("A1:L1").Copy Destination:=a.Range("A1")
fila = 2
For i = 2 To uf
   strg = b.Cells(i, 3).Value
   If UCase(strg) Like UCase(TextBox1.Value) & "*" Then
       a.Cells(fila, 1) = b.Cells(i, 1)
       a.Cells(fila, 2) = b.Cells(i, 2)
       a.Cells(fila, 3) = b.Cells(i, 3)
       a.Cells(fila, 4) = b.Cells(i, 4)
       a.Cells(fila, 5) = b.Cells(i, 5)
       a.Cells(fila, 6) = b.Cells(i, 6)
       a.Cells(fila, 7) = b.Cells(i, 7)
       a.Cells(fila, 8) = b.Cells(i, 8)
       a.Cells(fila, 9) = b.Cells(i, 9)
       a.Cells(fila, 10) = b.Cells(i, 10)
       a.Cells(fila, 11) = b.Cells(i, 11)
       a.Cells(fila, 12) = b.Cells(i, 12)
       fila = fila + 1
   End If
Next i


a.Range("D:G").NumberFormat = "dd/mm/yyyy"

uf = a.Range("A" & Rows.Count).End(xlUp).Row
uc = a.Cells(1, Columns.Count).End(xlToLeft).Address
wc = Mid(uc, InStr(uc, "$") + 1, InStr(2, uc, "$") - 2)
With Me.ListBox1
    .ColumnCount = 12
    .ColumnWidths = "20 pt; 15pt; 170 pt;50 pt;50 pt;50 pt;50 pt;50 pt;50 pt;50 pt;50 pt;50 pt"
    .RowSource = "DFSHJFDUYDAYRAIUY544TTTOMYDUTGD!A1:" & wc & uf
End With

a.Delete
End Sub

Private Sub TextBox2_Change()
If Len(UserForm1.TextBox2) = 10 Then UserForm1.TextBox3.SetFocus
End Sub

Private Sub TextBox3_Change()
If Len(UserForm1.TextBox3) = 10 Then UserForm1.CommandButton2.SetFocus
End Sub

Private Sub UserForm_Initialize()
Dim fila As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set b = Sheets("Hoja1")
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 = 12
    .ColumnWidths = "20 pt; 15pt; 170 pt;50 pt;50 pt;50 pt;50 pt;50 pt;50 pt;50 pt;50 pt;50 pt"
    .RowSource = "Hoja1!A1:" & wc & uf
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error GoTo Fin
If CloseMode <> 1 Then Cancel = True
Fin:
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