Antoni

Después de pulsar en el enlace, puede que te aparezca una pantalla de login a Dropbox, pero puedes obviarla en la parte inferior de dicho login. Verás el nombre del archivo en la parte izquierda, NO LO PULSES. Puedes descargar el archivo pulsando un enlace en la parte superior derecha de la pantalla. De todas forma he subido el archivo al otro foro donde hiciste la consulta. Consulta en todoexcel.com

¿Y pretendes que sin la base de datos Access y sin el archivo Excel te ayude alguien? ☹️

. Prueba así: Function Val_Buscado(Celda_Buscada As Range, Celda_Ref As Range, Columna As Range, Matriz As Range) Dim Columnas As Integer Dim valor As Double Application.Volatile Columnas = Columna.Find(Celda_Ref).Column - 1 valor = Application.WorksheetFunction.VLookup(Celda_Buscada, Matriz, Columnas, 0) Val_Buscado = valor End Function Sub Buscar() valor = Val_Buscado(Range("A15"), Range("K21"), Range("B21:K21"), Range("B21:K34")) End Sub y como fórmula, yo uso el punto y coma (;) como separador: =Val_Buscado(A15;K21;B21:K21:B21:K34) .

Abre el adjunto y pulsa sobre el cubilete. 🙂 https://www.dropbox.com/s/2vhno1pjybpa82f/Poker II.rar?dl=0

Creo que ya lo tengo, mañana lo pruebo a fondo y lo subo.🙂

No te prometo nada, pero mañana, si tengo tiempo, le echaré un vistazo a ver si podemos solucionarlo. En cualquier caso te diré algo.

Sin el archivo con la macro es imposible ayudarte.

Sub GuardarHistórico() For x = 2 To Hoja2.Range("A" & Rows.Count).End(xlUp).Row Set celda = Hoja1.Columns("A").Find(Hoja2.Range("C" & x), , , xlWhole) If celda Is Nothing Then Hoja1.Range("A" & Rows.Count).End(xlUp).Offset(1) = Hoja2.Range("C" & x) End If Next End Sub

Solo 2 cosas: El combobox no era ActiveX, ahora si. Las celdas con fórmula no activan el evento Worksheet_Change(). AYUDA EXCEL.xlsm

Lo que te he propuesto vale con la hoja, esté como este. No hace falta que hagas visible la hoja oculta.

Elimina todos los .Select y califica todos los rangos, ejemplo: Hoja3.Range("A1")=1 Hoja3.Range("A2")=1 o With Hoja3 .Range("A1")=1 .Range("A2")=1 End With y así con todos los rangos de todas las hojas, atención especial a ActiveSheet, cambia por Hoja3 o la que corresponda.

Si funciona, esta línea sustituye todo tu código.

Mejor así: Hoja3.Range(Hoja3.Columns("IA"), Hoja3.Columns("IA").End(xlToRight)).ClearContents

Si te gusta más así: Hoja3.Range(Columns("IA"), Columns("IA").End(xlToRight)).ClearContents

No siempre es necesario.

Revisa el adjunto. colocar fechas laborables segun seleccion del mes AyE2.xlsm

A mi me ha salido esto: Sub SeparaEnCol() For x = 7 To Range("B" & Rows.Count).End(xlUp).Row horas = Split(Range("B" & x), Chr(10)) Range("C" & x) = horas(0) Range("D" & x) = horas(1) Next End Sub

Esta macro hace lo que pides, o eso creo. El resultado se obtiene sobre la propia hoja Data. Sub AsignarCupones() Dim Data, Cupones, Fila '-- Application.ScreenUpdating = False Set Data = Sheets("Data") Set Cupones = Sheets("Cupones") '-- Fila = 1 For x = 2 To Data.Range("A" & Rows.Count).End(xlUp).Row Data.Range("D" & x) = "" For y = 1 To Data.Range("C" & x) Fila = Fila + 1 Data.Range("D" & x) = Data.Range("D" & x) & ";" & _ Cupones.Range("A" & Fila) Next Data.Range("D" & x) = Mid(Data.Range("D" & x), 2) Next End Sub '--

Primero no soy Gerson(No jerson), soy Antoni y si aplica. Otra cosa distinta es que no sepas como. existencias Gerson Pineda.xlsm

Prueba ahora. Prueba rango a jpg (1).xlsm

Te adjunto un archivo en el que funciona correctamente. Abre el archivo y pulsa sobre la flecha azul. Abre la imagen Prueba.jpg, Prueba rango a jpg.xlsm

Las fechas, tal como se ven, no dejan de ser números formateados y lo que tu planteas ocasionará que esas fechas pasen a ser texto, por lo que no vas a poder operar con ellas. Sub Macro1() For Each celda In Range("F5:F12") celda.Value = Format(celda, "dd.mm.yyyy") Next End Sub

Alguna vez me he encontrado con problemas a la hora de pegar imágenes en gráficos, así no hay problema. '-- Sub Macro3() CrearImagenRango ActiveSheet.UsedRange, "Prueba" End Sub '-- Private Sub CrearImagenRango(RANGO As Range, IMAGEN As String) Application.ScreenUpdating = False 'Creamos la imagen del rango y la pegamos en la hoja RANGO.CopyPicture Appearance:=xlScreen, Format:=xlPicture ActiveSheet.Paste 'Copiamos la imagen del rango y la eliminamos ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Copy ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Delete 'Añadimos el gráfico y lo redimensionamos ActiveSheet.Shapes.AddChart.Select With Selection .Height = RANGO.Height .Width = RANGO.Width .Top = RANGO.Top .Left = RANGO.Top End With With ActiveSheet.Shapes(ActiveSheet.Shapes.Count) .Line.Visible = msoFalse .Fill.ForeColor.RGB = Range("A1").Interior.Color End With 'Pegamos la imagen del rango en el gráfico ActiveChart.ChartType = xlColumnClustered ActiveChart.Paste 'Exportamos el gráfico como .jpg y lo eliminamos archivo = ThisWorkbook.Path & "\" & IMAGEN & ".jpg" ActiveChart.Export Filename:=archivo, Filtername:="JPG" ActiveChart.Parent.Delete End Sub

No es buena idea que personalices las consultas. Sustituye tu procedimiento por este: Private Sub CommandButton1_Click(): On Error Resume Next Dim Ctl As Control, Fram As Control For Each Ctl In Me.Controls If TypeOf Ctl Is MSForms.Frame Then For Each Fram In Ctl.Controls If TypeOf Fram Is MSForms.OptionButton Then If Fram.Value = True Then With Hoja2 vuf = .Range("B" & .Rows.Count).End(xlUp).Row + 1 .Cells(vuf, "B") = TextBox1 .Cells(vuf, "C") = TextBox2 .Cells(vuf, "D") = Ctl.Caption & " / " & Fram.Caption Select Case Ctl.Caption Case "Buzo Papel": .Cells(vuf, "E") = "00100" Case "Guantes": .Cells(vuf, "E") = "00101" Case "Antiparras": .Cells(vuf, "E") = "00102" Case "Lentes de Seguridad": .Cells(vuf, "E") = "00103" Case "Filtros": .Cells(vuf, "E") = "00104" Case "Mascarilla": .Cells(vuf, "E") = "00105" Case "Calzado de Seguridad": .Cells(vuf, "E") = "00106" End Select End With Fram.Value = False End If End If Next End If Next End Sub

Esta macro lo hace todo de una vez: Sub INTERVALOS_NO_UTILIADOS() Dim MES As Date Dim INF As Worksheet Dim AUX As Worksheet Dim CON As Range Dim FALTA As String '-- Set INF = Sheets("INFO") Set AUX = Sheets("AUXILIAR") CONCETAR.CONEXION '-- Application.ScreenUpdating = False MES = Format(Month(INF.Range("E5")), "mm/dd/yyyy") For i = 12 To 26 AUX.Cells.Clear Set Rs = New ADODB.Recordset Rs.Open "Select * From [DATOS$]" & _ " Where [CO]=" & INF.Range("A1") & " And" & _ " month([Fecha])= #" & MES & "# And" & _ " [DCTO2] ='" & INF.Range("C" & i) & "'" & _ " Order By [DCTO2], [CONSECUTIVO]", Cnn, adOpenKeyset, adLockOptimistic, adCmdText AUX.Range("A1").CopyFromRecordset Rs INF.Range("D" & i) = WorksheetFunction.Min(AUX.Columns("F")) INF.Range("E" & i) = WorksheetFunction.Max(AUX.Columns("F")) INF.Range("F" & i) = "" INF.Range("F" & i) = (INF.Range("E" & i) - INF.Range("D" & i)) _ - AUX.UsedRange.Rows.Count + 1 INF.Range("G" & i) = "" FALTA = "" If INF.Range("F" & i) > 0 Then For x = INF.Range("D" & i) To INF.Range("E" & i) Set CON = AUX.Columns("F").Find(x, , , xlWhole) If CON Is Nothing Then FALTA = ", " & x & FALTA Next INF.Range("G" & i) = Mid(FALTA, 3) End If If INF.Range("F" & i) = 0 Then INF.Range("F" & i) = "" Next i End Sub