Antoni

Abre el adjunto y pulsa sobre la flecha azul. Observa que he cambiado el diseño de la hoja Cuestionario Horizontal. Ejemplo (1).xls

¿Cuantas veces más vas a subir el mismo archivo sin datos y sin explicar que es lo que quieres, cuando hay que hacerlo y en que formulario? 🙁

Esta es la propiedad: ActiveSheet.Shapes(ShapeName).Fill.Transparency = valor (Entre 0 y 1) Por asociación con el resto de scrollsbar, no creo que un nuevo control para que controle esta propiedad.

Puedes conseguirlo ocultando filas y columnas o con un label que oculte la información y lo muestras/ocultas a voluntad.

Sube uno de los archivos.

Casi lo tenías. A ver que tal. Mi_Calendario.xlsm

¡Muy bueno!

A la espera del permiso para descargar el archivo, prueba a ver si funciona: Function EliminarRegistros() With listboxpalau If MsgBox("Estas seguro de que quieres eliminar el registro seleccionado?", _ vbYesNo + vbQuestion, "Eliminar resgitros") = vbYes Then For a = .ListCount - 1 To 0 Step -1 If .Selected(a) = True Then Set celda = Columns("A").Find(.List(a, 0), , , xlWhole) Sheets("BD").Rows(celda.Row).Delete .RemoveItem a End If Next End If End With End Function

A ver si es esto lo que quieres: Sub opentxt() '.... '.... i = InStr(textData, "GROUP BY") textData = Left(textData, i - 1) & "WHERE C.[CODIGO REL] = '" & TextBox1 & "' " & Mid(textData, i) End Sub

El método Find da error cuando no encuentra la celda con el valor buscado. Prueba así y si no te funciona, sube el archivo. DatoEncontrado = Usuarios.Rango.Find(What:=Me.TxtUsuario.Value, MatchCase:=False, lookat:=xlWhole).Address

Sql = "SELECT C.FOLIO, C.[ESTADO DATOS], C.[CODIGO REL]" Sql = Sql & " FROM CABECERAMOVIMIENTO AS C" Sql = Sql & " WHERE C.[CODIGO REL] = '" & TextBox1 & "'" Sql = Sql & " GROUP BY C.FOLIO, C.[ESTADO DATOS], C.[CODIGO REL]"

Después de crear la instancia a Excel: XL.Application.ScreenUpdating =False

Para ocultar la aplicación: Application.Visible = False en el evento Workbook_Open Para poder trabajar con Excel mientras el formulario está mostrado: Userform1.Show vbModeless

Sub EncriptaDesencriptaPNAC() Application.ScreenUpdating = False x = 2 i = Timer Do Until Range("A" & x) = "" For y = 1 To 7 Cells(x, y) = EncriptaDesencripta(Cells(x, y)) Next If x Mod 5000 = 0 Then Application.StatusBar = "Procesando fila: " & x & " Tiempo total: " & Timer - i Application.ScreenUpdating = True DoEvents Application.ScreenUpdating = False End If x = x + 1 Loop End Sub Prueba así, en la barra de estado de Excel irá apareciendo el avance del proceso, el tiempo total para encriptar el archivo que has subido ha sido de 45 minutos más o menos. (2 GB de RAM a 1,8 Mz) En cuanto a la búsqueda en el formulario, es inviable desencriptar los datos cada vez que cargas el formulario. El único proceso de búsqueda es por valor exacto, por aproximación no es posible por la gran cantidad de información. Excel no esta pensado para tratar volúmenes de información como el que planteas. Si te interesa una búsqueda como la planteada, sube un archivo con unos centenares de registros y el formulario correcto, ya que en el último archivo el formulario y los datos no se corresponden.

'Ejemplo encriptar/desencriptar toda la hoja PNAC Sub EncriptaDesencriptaPNAC() Application.ScreenUpdating = False x = 2 Do Until Range("A" & x) = "" For y = 1 To 7 Cells(x, y) = EncriptaDesencripta(Cells(x, y)) Next x = x + 1 Loop End Sub 'Ejemplo para la fila 100 Sub EjemploFila100() Application.ScreenUpdating = False For y = 1 To 7 Cells(100, y) = EncriptaDesencripta(Cells(100, y)) Next End Sub Nota: En el archivo que has subido hay unas 7.000 filas con información y más de 1.000.000 en blanco.

Algo sencillo, te dejo una función que encripta/desencripta de forma alternativa. Con la hoja PNAC activada: 'En un módulo normal Function EncriptaDesencripta(Texto As String) As String For y = 1 To Len(Texto) Mid(Texto, y, 1) = Chr(255 - Asc(Mid(Texto, y, 1))) Next EncriptaDesencripta = Texto End Function Sub Ejemplo() 'Ejemplo de funcionamiento de la función Range("B2") = EncriptaDesencripta(Range("B2")) End Sub

¡Ya está! Para mostrar una imagen que está en la hoja, hay que convertirla a jpg previamente. Abre el adjunto y pulsa sobre un código QR de la columna C. GENERADOR CODIGO QR.xlsm

No se puede, utiliza un userform con un label.

TextBox6 = Sheets("La hoja que quieras").Range("C10")

Abre el adjunto y pulsa en GENERAR CÓDIGOS QR y después en ELIMINAR CÓDIGOS QR. Mañana, si puedo, te mostraré como visualizar un código QR en un userform. GENERADOR CODIGO QR.xlsm

Prueba con la macro así: Sub Delete() Dim starTime As Double Dim x As Integer Dim ultRow As Integer Dim ultCol As Integer Application.ScreenUpdating = False With dataPrenomina ultRow = .Cells(Rows.Count, 2).End(xlUp).Row ultCol = .Cells(1, Columns.Count).End(xlToLeft).Column starTime = Timer For x = ultRow To 2 Step -1 If Application.Sum(.Range("H" & x).Resize(1, ultCol - 7)) = 0 Then .Rows(x).Delete End If Next x MsgBox "Timer is: " & Format(Timer - starTime, "##,##0.00") End With End Sub

letras = Split(Columns(número).Address, "$")(2)

Sub Busca() Dim Leyenda As String Application.ScreenUpdating = False For x = 2 To Range("A" & Rows.Count).End(xlUp).Row Leyenda = "" Select Case Range("B" & x) Case Is < 0: Leyenda = "Menor que cero." Case 0: Leyenda = "Igual a cero." Case Is > 0: Leyenda = "Mayor que cero." End Select If Not Range("A" & x) = Range("A" & x + 1) Then Leyenda = Leyenda & " Última fila = " & x & "." End If Range("C" & x) = Leyenda Next End Sub

Un poco mas ortodoxo. Sub ActualizarColor() Application.ScreenUpdating = False For Each motor In ActiveSheet.Shapes motor.Select If Selection.Formula <> "" Then Selection.ShapeRange.Fill.ForeColor.RGB = _ Range(Selection.Formula).Offset(3).DisplayFormat.Interior.Color End If Next ActiveCell.Select End Sub

Prueba, no creo que tengas problemas para entenderlo. Y te recuerdo que los controles no son textbox, son combobox, con textbox no se puede hacer. BUENO (1).xlsm