Como seleccionar directorio con Explorador buscar archivos y renombrarlo cambiando nombre





Macro que permite seleccionar directorio con Explorador de Archivos de Windows busca archivos y renombra ficheros, anteriormente se presentó una variante que directamente se establecía la ruta del directorio en la macro en este caso se da la opción al operador  de seleccionar el archivo, esto es más adecuado cuando el directorio donde se encuentran los archivos a buscar y modificar no es siempre constante, dando la versatilidad para poder seleccionar el directorio cada vez que se ejecuta la macro.

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.

  

El vídeo verás la macro en acción con una explicación más detallada de su codificación y funcionamiento, recomiendo observar para una más fácil comprensión de la macro; suscribe a nuestra web desde la parte superior derecha de la página ingresando tu mail y a nuestro canal de You Tube para recibir en tu correo vídeos explicativos sobre macros interesantes, como  por ejemplo Recorre fila buscando y comparando datos de dos columnas en hojas distintasbuscar en listbox mientras escribes en textbox, como crear una factura o sale invoice y grabar guardar PDF XLS y enviar por mailconectar Excel con Access y muchos ejemplos más.








  

Por favor considera la posibiliad de aportar para sostener el sitio, desde el link del final del post se puede descargar el ejemplo de macro, cada usuario puede adaptarlo a sus necesidades, la codificación está abierta y es de libre, se brinda en forma gratuita.

El fichero que se descarga en un archivo comprimido ZIP, que contiene la macro y una carpeta con archivos que utiliza el ejemplo denominado como seleccionar directorio con explorador de archivos buscar fichero y renombrar cambiando solo una parte de su nombre; la condición es descomprimir en cualquier directorio.

Al presionar el botón para ejecutar la macro, se muestra un explorador de archivos que permite seleccionar la carpeta o directorio donde están los archivos cuyo nombre se modificarán, la macro realiza un bucle recorriendo todos los archivos del directorio, modificando su nombre.

La macro no modifica totalmente el nombre solo una parte, básicamente la macro determina donde está el número que se encuentra en el nombre de la macro, que a su vez es el código con el que se identifica en el archivo de Excel, detectado el número lo extrae, extrae la cadena de texto anterior al número y la posterior, para luego concatenar, estableciendo el nombre del archivo teniendo presente que el número va primero luego la primer parte de la cadena de texto y por último la ultima parte de la cadena de texto que formaba el nombre del archivo, para comprender en forma fácil lo que se está explicando, sugiero ver el vídeo tutorial también.

Para realizar lo mencionado se utilizan los siguientes códigos, el primero establece en la variable path1 la dirección o ruta de la carpeta seleccionada

path1 = CreateObject("shell.application").browseforfolder(0, "Seleccione Carpeta", 0).Items.Item.Path

Con estos códigos se forma el nombre del archivo, ver vídeo tutorial explica en detalle:

    b = ficheros.Name
    nomold = path1 & "\" & b
    esp1 = InStr(b, " ")
    esp2 = InStr(esp1 + 1, b, " ")
    num = Mid(b, esp1 + 1, esp2 - 1 - esp1)
    pp = Left(b, esp1 - 1)
    sp = Mid(b, esp2 + 1)
    nomnew = path1 & "\" & num & " " & pp & " " & sp

Para renombrar el archivo se apela al siguiente código: Name nomold As nomnew


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

Crear una colección de datos y buscar uno por uno

Guardar un archivo Excel con una fecha como nombre

Mostrar en el mismo listbox, suma, cuenta y promedio

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



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

Luego de renombrar el archivo, la macro busca en la columna A del fichero Excel el número con el que comienza el fichero, que a su ves es el código que hace referencia al archivo correspondiente, encontrado el archivo se coloca en la columna F la dirección o ruta al archivo y en la columna A se crea un hiperlink, hipervinculo o link al archivo, una vez hecho esto haciendo click en el código de la columna A se abre el archivo correspondiente.

Para crear el link al archivo se utiliza el siguiente código:

texhipv = a.Range("A" & codigo.Row)
dire = codigo.Row

La variable texhipv guarda el texto que se verá en el link, dire contiene la fila donde está el registro que coincide con el archivo y luego se hace el link al archivo, con el código que sigue, si se observa se ve como se utilizan las variables para formar el link al archivo; a continuación se muestra el código completo.

a.Hyperlinks.Add Anchor:=a.Range("A" & dire), Address:=nomnew, TextToDisplay:=texhipv
NunFich = NunFich + 1


Código que se inserta en un módulo


Sub hiperlinkficheroYURL()
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim path1 As String, ruta As String, texhipv As String
Set a = Sheets(ActiveSheet.Name)
uf = a.Range("A" & Rows.Count).End(xlUp).Row
'path1 = ActiveWorkbook.Path & "\324 PruebaHyper"
path1 = CreateObject("shell.application").browseforfolder(0, "Seleccione Carpeta", 0).Items.Item.Path
 If path1 = "" Then
 MsgBox "No ha seleccionado directorio carpeta Excel, seleccione directorio .", , "AVISO"
 Exit Sub
 End If
Set fso = CreateObject("Scripting.FileSystemObject")
Set carpeta = fso.getfolder(path1)
Set ficheros = carpeta.Files
NunFich = 0
num = 0
For Each ficheros In ficheros
    b = ficheros.Name
    nomold = path1 & "\" & b
    esp1 = InStr(b, " ")
    esp2 = InStr(esp1 + 1, b, " ")
    num = Mid(b, esp1 + 1, esp2 - 1 - esp1)
    pp = Left(b, esp1 - 1)
    sp = Mid(b, esp2 + 1)
    nomnew = path1 & "\" & num & " " & pp & " " & sp

Name nomold As nomnew

busco = num
Set codigo = a.Range("A5:A" & uf).Find(busco, LookIn:=xlValues, LookAt:=xlWhole)
If Not codigo Is Nothing Then
a.Range("F" & codigo.Row) = nomnew
texhipv = a.Range("A" & codigo.Row)
dire = codigo.Row
a.Hyperlinks.Add Anchor:=a.Range("A" & dire), Address:=nomnew, TextToDisplay:=texhipv
NunFich = NunFich + 1

End If
Next ficheros

Set carpeta = Nothing
Set ficheros = Nothing
MsgBox ("Se encontraron " & NunFich & " ficheros en la carpteta seleccionada"), vbInformation, "AVISO"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
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      

Calendario Agenda 2018 en Excel





En este post se podrá descargar el Calendario Agenda 2018, realizado en Excel, contiene muchas macros que se pueden encontrar y descargar gratuitamente de esta página, se utiliza formularios y distintos procedimientos o macros que lo hacen funcional, no utiliza prácticamente ninguna fórmula incorporadas en 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.

  

Mira por favor el vídeo para ver su funcionamiento, entorno que enseñará en forma fácil su utilidad; suscribe a nuestra web desde la parte superior derecha de la página ingresando tu mail y a nuestro canal de You Tube para recibir en tu correo vídeos explicativos sobre macros interesantes, como  por ejemplo Recorre fila buscando y comparando datos de dos columnas en hojas distintasbuscar en listbox mientras escribes en textbox, como crear una factura o sale invoice y grabar guardar PDF XLS y enviar por mailconectar Excel con Access y muchos ejemplos más.







  


Desde el link que se encuentra en el final se puede descargar en forma gratuita el Calendario Agenda 2018 en Español, pero considera aportar para sostener el sitio.

Al descargar el Calendario Agenda 2018, se verá al lado izquierdo que se encuentra el listado de meses de Enero a Diciembre, presionando en el mes deseado se mostrará el mismo, si se requiere visualizar todos se debe presionar el botón que está al principio denominado "Todos", ello hará que se muestre el calendario con todos los meses del año.




Haciendo doble click en el calendario sobre un día en particular, se muestra un formulario que permite ingresar la tarea o actividad que se desea agendar, pudiendo ingresar la hora de inicio y fin si se requiere, también a pesar de salir por defecto el día en el cual hicimos click, se puede cambiar manualmente asignando el día que se desee para la tarea que se intenta agregar.




Presionando el botón guardar al final del formulario se guarda la tarea y se agrega en el listado de tareas que se encuentra a la derecha de la hoja ordenándose en forma automática por fecha luego por hora de inicio y por hora de fiscalización de la tarea.

⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛
Quizás también sea útil:

Buscar datos por cliente entre fecha y fecha y cargar en listbox

Crear factura en Excel guardar en PDF y enviar por mail




Crear factura en Excel y descontar de Stock al facturar

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

También es factible imprimir el calendario ello se realiza desde el botón que se encuentra al principio del archivo a la derecha, presionando se procede a imprimir el listado de tareas adendadas como muestra en la imagen siguiente:


También se puede imprimir el calendario, la impresión tomará una forma distinta, imprimiendo una hoja por cada mes ocupando toda la hoja A4 al final del calendario se deja unas lineas destinadas para la escritura de notas, el calendario se imprime en forma grande dejando espacio en el mismo día para anotaciones, tal cual la imagen que a continuación se muestra.



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 buscar archivos y renombrarlo cambiando partes de su nombre





En este ejemplo se apela a las funciones de VBA para trabajar con cadenas de texto y se aplica al renombramiento de archivos, por ello el ejemplo se llama como buscar archivos y renombrarlo cambiando partes de su nombre, anteriormente se mostraron otros ejemplos que tratan sobre la búsqueda de archivos y los encuentras en como buscar un archivo en una carpeta y determinar su ruta o path o como buscar archivos en una carpeta y hacer un link al fichero.

En el caso que puedas considera aportar para sostener el sitio, el ejemplo será mucho más fácil de comprender si se descarga el archivo comprimido (ZIP) donde está el ejemplo y la carpeta con archivos con las que trabaja el ejemplo; aconsejo descargarlo con la única condición que se debe guardar juntos no importando en que parte del los directorios de la PC se guarden.

⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛
Lee también
Listar archivos y carpetas de un directorio
Como abrir, modificar e imprimir arhivos de Word desde Excel con macro
Como abrir dos libros copiar datos de uno a otro y guardar en un tercer libro
⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛

Antes de seguir lee 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.

  

El vídeo muestra una explicación más gráfica y ayuda mucho a comprender el funcionamiento de la macro de ejemplo que se muestra en este post denominada como buscar archivos y renombrarlo cambiando partes de su nombre; suscribe a nuestra web desde la parte superior derecha de la página ingresando tu mail y a nuestro canal de You Tube para recibir en tu correo vídeos explicativos sobre macros interesantes, como  por ejemplo Recorre fila buscando y comparando datos de dos columnas en hojas distintasbuscar en listbox mientras escribes en textbox, como crear una factura o sale invoice y grabar guardar PDF XLS y enviar por mailconectar Excel con Access y muchos ejemplos más.








  


Ejemplo toma cada uno de los archivos que se encuentran en la carpeta que que adjunta como ejemplo, los renombra, en este caso se toma el mismo nombre del archivo se le extrae un número que contiene inserto en su nombre y se coloca ese número al principio del nombre, ello es posible con las funciones de VBA que permiten trabajar con cadenas de texto.

Lo anterior es posible con está serie de códigos:

b = ficheros.Name
    nomold = path1 & "\" & b
    esp1 = InStr(b, " ")
    esp2 = InStr(esp1 + 1, b, " ")
    num = Mid(b, esp1 + 1, esp2 - 1 - esp1)
    pp = Left(b, esp1 - 1)
    sp = Mid(b, esp2 + 1)
    nomnew = path1 & "\" & num & " " & pp & " " & sp

Con los códigos anteriores se busca a partir del nombre del archivo donde está el número que está inserto en el nombre del archivo por ello se busca el primer espacio y donde está el segundo espacio ya que entre ellos está el número que necesitamos extraer, luego mediante una resta entre la cantidad de caracteres de la cadena se determina cuantos caracteres se deben extraer, ya que el numero puede tener una cifra, dos cifras o tres cifras, entonces restando la cantidad de caracteres a la izquierda menos los caracteres a la derecha nos da la cantidad de caracteres a extraer del total, con ello se extrae el número que se requiere, y la cadena de texto que está antes del número y posterior al número para luego concatenarlos alterando su nombre.

Realizado lo mencionado, se renombra el archivo con este código:

Name nomold As nomnew

Una vez renombrado el archivo, se recorre todos los archivos del directorio con un bucle, buscando el número del fichero que ahora está al comienzo del nombre, porque fue renombrado; en la columna A del archivo de Excel donde se encuentra dicho número que es un código que hace referencia al archivo, una vez encontrado crea un link al archivo.

Para saber saber más sobre como crear un link, por favor visita como crear un link al archivo, el código completo del ejemplo denominado como buscar archivos y renombrarlo cambiando partes de su nombre, se expone a continuación.

Código que se inserta en un módulo



Sub hiperlinkficheroYURL()
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim path1 As String, ruta As String, texhipv As String
Set a = Sheets(ActiveSheet.Name)
uf = a.Range("A" & Rows.Count).End(xlUp).Row
path1 = ActiveWorkbook.Path & "\324 PruebaHyper"
Set fso = CreateObject("Scripting.FileSystemObject")
Set carpeta = fso.getfolder(path1)
Set ficheros = carpeta.Files
NunFich = 0
num = 0
For Each ficheros In ficheros
    b = ficheros.Name
    nomold = path1 & "\" & b
    esp1 = InStr(b, " ")
    esp2 = InStr(esp1 + 1, b, " ")
    num = Mid(b, esp1 + 1, esp2 - 1 - esp1)
    pp = Left(b, esp1 - 1)
    sp = Mid(b, esp2 + 1)
    nomnew = path1 & "\" & num & " " & pp & " " & sp

Name nomold As nomnew

busco = num
Set codigo = a.Range("A5:A" & uf).Find(busco, LookIn:=xlValues, LookAt:=xlWhole)
If Not codigo Is Nothing Then
a.Range("F" & codigo.Row) = nomnew
texhipv = a.Range("A" & codigo.Row)
dire = codigo.Row
a.Hyperlinks.Add Anchor:=a.Range("A" & dire), Address:=nomnew, TextToDisplay:=texhipv
NunFich = NunFich + 1

End If
Next ficheros

Set carpeta = Nothing
Set ficheros = Nothing
MsgBox ("Se encontraron " & NunFich & " ficheros en la carpteta seleccionada"), vbInformation, "AVISO"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
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      

Pasar datos listbox multiselect a distintas hoja Excel dependiendo de condición





Un suscriptor de nuestro canal de Youtube solicita ayuda respecto a una variante de un tutorial presentado anteriormente denominado como pasar datos de listbox multiselect a hoja de Excel, difiere el presente ejemplo con el mencionado anteriormente en que los datos seleccionados en el listbox se pasará a distintas hojas de Excel dependiendo de condición no a una sola hoja de Excel, ello es lo que da origen a la macro llamada como pasar datos de listbox multiselect a distintas hojas de Excel dependiendo de condición.

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.

  

El vídeo muestra el funcionamiento de la macro en forma visual lo que hará más fácil comprender el funcionamiento del ejemplo de macro presentado en este post; suscribe a nuestra web desde la parte superior derecha de la página ingresando tu mail y a nuestro canal de You Tube para recibir en tu correo vídeos explicativos sobre macros interesantes, como  por ejemplo macro de Excel que permite comprimir archivos con extensión ZIP, macro que recorre fila busca el dato y resalta la fila donde se encuentra, marcar celda cuando la sumatoria llegue a cierto valor y muchos ejemplos más.









  

Por favor considera aportar para sostener el sitio recuerda que todos los ejemplos son gratuitos, el fichero se puede descargar en forma totalmente gratuita desde el final del post, se solicita se comparta el post en las redes sociales, like si fue útil.

Al descargar el ejemplo se puede observar en el libro de Excel una vez abierto, dos botones, un botón muestra el formulario con el respectivo listbox y otro botón que borra los datos de las distintas hojas para poder ejecutar la macro una y otra vez sin acumular una gran cantidad de registros en la hoja, es algo opcional.

⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛
Quizás interese también:

Pasar datos de listbox a hoja de Excel

Cargar datos en textbox y pasar a listbox

Como pasar datos de un listbox a otro listbox con doble click

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

Al presionar el botón que permite mostrar el formulario, se observa un userform con un listbox que al iniciar carga los datos de la base de datos que está en la Hoja2, el listbox es multiselect, esto significa que permite seleccionar varios ítem a la vez; también se puede observar en el userform dos botones, uno para salir y el otro para pasar los datos seleccionados en el listbox a la Hoja de Excel.

La macro contiene hojas con las marcas de productos "SEDAL", "ARCOR" y "BAGLEY", si en el listbox se seleccionan artículos con estas marcas se pasarán a la hoja correspondiente en caso que no coincidan con estás marcas, es decir sea cualquier otra marca de producto se guardan en la HOJA1.

La macro establece condiciones antes de pasar los datos del listbox a la hoja de Excel, esta es la diferencia con el ejemplo original que directamente pasaba lo seleccionado a la Hoja1.

El siguiente código es el que determina la condición que se debe cumplir para pasar los datos a una u otra hoja, en primer lugar se detecta cual es la marca del productos seleccionado en el listbox, en este caso se encuentra en la columna 3 del listbox (recuerden las columnas del listbox se empiezan a contar desde cero), una vez detectado cual es la marca del producto seleccionado en el listbox se apela a estructura Select Case (click en el link para saber mas sobre el uso de Select Case).

marsel = Me.ListBox1.List(x, 3)
Select Case marsel
Case Is = "arcor"
Marca = "Arcor"
Case Is = "sedal"
Marca = "Sedal"
Case Is = "bagley"
Marca = "Bagley"
End Select
        
If Marca = Empty Then Marca = "Hoja1"
Set a = Sheets(Marca)

Dependiendo de la marca del producto seleccionado se establece el nombre de la hoja, si la hoja no es igual a alguna de las tres marcas expuestas se otorga el nombre Hoja1; posteriormente a hace un objeto usando como nombre de hoja el de la marca seleccionada, el resto de la codificación es igual que el ejemplo como pasar datos de listbox multiselect a hoja de Excel por lo que si es necesario aprender sobre su funcionamiento recomiendo echarle un vistazo.

Recuerda que el ejemplo que denominado como pasar datos de listbox multiselect a distintas hojas de Excel dependiendo de condición se puede descargar desde el link del final, a continuación se expone toda la codificación que contiene el ejemplo y que se podrá observar al descargar el ejemplo y editar con el editor de Visual Basic Aplication. (VBA).

Código que se inserta en un módulo


Sub muestra1()
UserForm1.Show
End Sub
Sub borrar()

uf = Sheets("Hoja1").Range("A" & Rows.Count).End(xlUp).Row
If uf = 1 Then uf = 2
Sheets("Hoja1").Range("A2" & ":H" & uf).Clear

uf = Sheets("Arcor").Range("A" & Rows.Count).End(xlUp).Row
If uf = 1 Then uf = 2
Sheets("Arcor").Range("A2" & ":H" & uf).Clear

uf = Sheets("Sedal").Range("A" & Rows.Count).End(xlUp).Row
If uf = 1 Then uf = 2
Sheets("Sedal").Range("A2" & ":H" & uf).Clear

uf = Sheets("Bagley").Range("A" & Rows.Count).End(xlUp).Row
If uf = 1 Then uf = 2
Sheets("Bagley").Range("A2" & ":H" & uf).Clear
End Sub



Código que se inserta en un formulario

Private Sub CommandButton1_Click()
Unload Me
End Sub

Private Sub CommandButton2_Click()
Dim conta As Integer
On Error Resume Next
conta = 0
For x = 0 To Me.ListBox1.ListCount - 1
    If Me.ListBox1.Selected(x) = True Then
    conta = conta + 1
    End If
Next x
If conta = 0 Then
MsgBox "Debe seleccionar un item para copiar en hoja de Excel", vbInformation, "AVISO"
Exit Sub
End If
conta = 0

For x = 0 To Me.ListBox1.ListCount - 1
Marca = Empty
If Me.ListBox1.Selected(x) = True Then
marsel = Me.ListBox1.List(x, 3)
Select Case marsel
Case Is = "arcor"
Marca = "Arcor"
Case Is = "sedal"
Marca = "Sedal"
Case Is = "bagley"
Marca = "Bagley"
End Select
        
If Marca = Empty Then Marca = "Hoja1"
Set a = Sheets(Marca)
filaedit = a.Range("A" & Rows.Count).End(xlUp).Row + 1
          
a.Cells(filaedit, "A") = ListBox1.List(x, 0)
a.Cells(filaedit, "B") = ListBox1.List(x, 1)
a.Cells(filaedit, "C") = ListBox1.List(x, 2)
a.Cells(filaedit, "D") = ListBox1.List(x, 3)
a.Cells(filaedit, "E") = ListBox1.List(x, 4)
a.Cells(filaedit, "F") = ListBox1.List(x, 5)
a.Cells(filaedit, "G") = ListBox1.List(x, 6)
a.Cells(filaedit, "H") = ListBox1.List(x, 7)
Me.ListBox1.Selected(x) = False
filaedit = filaedit + 1
End If
Next x
End Sub


Private Sub TextBox1_Change()
On Error Resume Next
Set b = Sheets("Hoja2")
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 = "Hoja2!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, 3).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)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 7) = b.Cells(i, 8)
   End If
Next i
Me.ListBox1.ColumnWidths = "20 pt;70 pt;180 pt;80 pt;60 pt;60 pt;60 pt;60pt"
End Sub
Private Sub TextBox2_Change()
On Error Resume Next
Set b = Sheets("Hoja2")
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 = "Hoja2!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, 4).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;70 pt;180 pt;80 pt;60 pt;60 pt;60 pt;60pt"
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 = 8
    .ColumnWidths = "20 pt;70 pt;180 pt;80 pt;60 pt;60 pt;60 pt;60pt"
    .RowSource = "Hoja2!A2:" & 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


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