Jump to content

Antoni

Members
  • Posts

    11,486
  • Joined

  • Last visited

  • Days Won

    814

Community Answers

  1. Antoni's post in Copiar columnas en distinto orden was marked as the answer   
    Asegúrate de tener activado el acceso al modelo de objetos de proyectos VBA:
     
  2. Antoni's post in Formulario Mantenimiento de Listas was marked as the answer   
    Te dejo resuelta una lista, el resto, por asociación, no deberías tener problemas.
    Private Sub CMBIngresaAutor_Click() With Sheets("Listas") If Not Trim(TXTAutor) = "" Then .Range("B" & Rows.Count).End(xlUp).Offset(1) = TXTAutor Else Beep End If .Range("B7").CurrentRegion.Sort Key1:=.Columns("B"), Header:=xlYes 'Reordena la lista CMBLimpiaAutor_Click End With End Sub Private Sub CMBLimpiaAutor_Click() TXTAutor = "" End Sub  
  3. Antoni's post in Hoja Con Botones Flotantes Donde No Se Puede Tener Botones. was marked as the answer   
    Te dejo tus macros algo más reducidas.
    Sustitúyelas por estas:
    Asignar macro a los círculos, debes ejecutarla una sola vez:
    Sub AsignarMacro() 'Asigna la macro Ovalos a todas las formas Dim s As Shape For Each s In ActiveSheet.Shapes If s.Name Like "Flotante*" Then s.OnAction = "Sheet3.Ovalos" Next End Sub Posicionar círculos:
    Private Sub Worksheet_SelectionChange(ByVal Target As Range): On Error Resume Next 'Procedimiento para ubicar los ovalos Const xTop As Integer = 40 Const xLeft As Integer = 50 Dim x As Integer, y As Integer, s As Shape For Each s In ActiveSheet.Shapes If s.Name Like "Flotante*" Then y = Mid(s.Name, 13) s.Top = ActiveCell.Top + xTop * x s.Left = ActiveCell.Left + ((1 - (y Mod 2)) + 1) * xLeft If y Mod 2 = 0 Then x = x + 1 End If Next Exit Sub End Sub Inicializar círculos al activar la hoja:
    Private Sub Worksheet_Activate(): On Error Resume Next 'Cambia las formas de color a verde al activar la hoja Dim s As Shape Application.ScreenUpdating = False For Each s In ActiveSheet.Shapes If s.Name Like "Flotante*" Then s.Fill.ForeColor.RGB = vbGreen Next End Sub Acciones al pulsar sobre los circulos:
    Sub Ovalos(): On Error Resume Next 'Cambio de color shapes (formas) Application.ScreenUpdating = False y = Mid(Application.Caller, 13) Select Case ActiveSheet.Shapes(Application.Caller).Fill.ForeColor.RGB Case vbGreen ActiveSheet.Shapes(Application.Caller).Fill.ForeColor.RGB = vbYellow MsgBox "Acción 1, Botón " & y, vbInformation Case vbYellow ActiveSheet.Shapes(Application.Caller).Fill.ForeColor.RGB = vbRed MsgBox "Acción 2 Botón " & y, vbInformation Case vbRed ActiveSheet.Shapes(Application.Caller).Fill.ForeColor.RGB = vbGreen MsgBox "Acción 3 Botón " & y, vbInformation End Select End Sub  
    Botones Flotantes.xlsb
  4. Antoni's post in Copiar hojas de excel con fechas was marked as the answer   
    Sub GenerarAño() Application.ScreenUpdating = False año = InputBox("Indique el año") inicio = CDate("01/01/" & año) fin = CDate("31/12/" & año) For fecha = inicio To fin Sheets(1).Copy After:=Sheets(Sheets.Count) Sheets(Sheets.Count).Name = Replace(fecha, "/", "-") Next End Sub  
  5. Antoni's post in Fórmula para calcular la diferencia en días, horas y minutos was marked as the answer   
    Si las fechas están en A1 y B1, en C1 pon:
    =A1 - B1
    y a C1 le das formato personalizado: 
    [H]:mm:ss
  6. Antoni's post in Combinar celdas iguales en fila - macro was marked as the answer   
    He modificado las macros para que el mismo botón sirva para combinar/descombinar las fechas de forma alternativa.
    En cuanto al mensaje, debes tener en cuenta que cuando combinas celdas que contienen datos, solo se conservan los de la primera celda, de ahí el aviso.
    No ocurre así en la macro ya que esto se ha tenido en cuenta y se conservan los datos de todas las celdas dentro de la celda combinada.
    Formato Genérico GANTT.xlsm
  7. Antoni's post in Contador de imágenes con limite (2) was marked as the answer   
    Esto ha estado muy fácil, a ver si e inventas una chorrada de las tuyas para entretenerme. 🤣
    MTop.xlsm
  8. Antoni's post in Obtener nombres de colunmas en un arreglo o array was marked as the answer   
    Otra forma
    Sub EncabezadoArrayII() Dim MyArray As Variant MyArray = Range("A1", Cells(1, Columns.Count).End(xlToLeft)) End Sub En este caso el array es de 2 dimensiones por lo que te has de referir a un elemento así:
    MyArray(1, c) siendo c el  número de columna.
    En cualquier caso, puede que el array sea innecesario, basta con recorrer la fila 1 con:
    For y = 1 To Cells(1, Columns.Count).End(xlToLeft).Column ... ... Next  
  9. Antoni's post in Problema con Abrir un Libro por Password vencido. was marked as the answer   
    Con lo cual llegamos a la conclusión que este tipo de protecciones no sirven para nada. 😒
  10. Antoni's post in File Dialog para copiar y pegar info de un libro a otro. was marked as the answer   
    Prueba a ver si es esto lo que buscas:
    Sub Prueba_Ytb_2() Dim FileToOpen As Variant Dim OpenBook As Workbook Application.ScreenUpdating = False FileToOpen = Application.GetOpenFilename(Title:="Seleccionar archivo", FileFilter:="Excel Files(*.xls*),*xls*") If FileToOpen <> False Then Set OpenBook = Application.Workbooks.Open(FileToOpen) OpenBook.Sheets(7).Range("C6:K" & OpenBook.Sheets(7).Range("C" & Rows.count).End(xlUp).Row).Copy ThisWorkbook.Worksheets("Hoja1").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues OpenBook.Close End If Application.ScreenUpdating = True End Sub  
  11. Antoni's post in Solucionar el Error 91 en tiempo de ej..... was marked as the answer   
    Prueba así a ver si te vale:
    Private Sub CargarLista() Dim x As Long, Nombre As Range CmbID.Clear For x = 28 To Hoja4.Range("E28").End(xlDown).Row CmbID.AddItem Hoja4.Range("E" & x) Set Nombre = Hoja2.Columns("A").Find(Hoja4.Range("E" & x), , , xlWhole) If Not Nombre Is Nothing Then CmbID.List(CmbID.ListCount - 1, 1) = UCase(Nombre.Offset(, 1)) '<------ CmbID.List(CmbID.ListCount - 1, 2) = Hoja4.Range("F" & x).Text Next TxtTotalR.Text = FormatNumber(Hoja4.Range("F26"), 2) For x = 0 To CmbID.ListCount - 1 If CmbID.List(x, 2) = "" Then CmbID.ListIndex = x Exit For End If Next End Sub  
  12. Antoni's post in De modelo CUADRANTE de TURNOS a modelo BASE de DATOS was marked as the answer   
    Esta macro convierte el cuadrante de turnos en formato tabla de BD.
    Válida para cualquier mes y número de trabajadores.
    Sub aBaseDeDatos() Application.ScreenUpdating = False With Sheets("DeCuaABase") .Range("A8").CurrentRegion.Offset(1).ClearContents fila = 8 For y = .Range("S9").Column To .Cells(8, Columns.Count).End(xlToLeft).Column For x = 8 To .Range("R" & Rows.Count).End(xlUp).Row fila = fila + 1 .Range("A" & fila) = .Cells(x, 17) .Range("B" & fila) = .Cells(6, y) .Range("C" & fila) = .Cells(x, 18) .Range("D" & fila) = .Cells(x, y) Next Next End With Application.ScreenUpdating = True End Sub  
  13. Antoni's post in Duda con la función VLookup y formato de fecha. was marked as the answer   
    Se supone que el dato buscado es una fecha, prueba así:
    Me.LblVence.Caption = Format(Application.WorksheetFunction.VLookup(Me.CmbNTarjeta.Text, Hoja5.Range("I:K"), 3, 0), "mm/yy")  
  14. Antoni's post in Recorrer un rango de celdas y exportar datos a otra hoja was marked as the answer   
    No se si lo he entendido, si no es así, tendrás que subir el archivo y poner un ejemplo de lo que quieres.
    Public Sub enviar_datos() Application.ScreenUpdating = False Dim celda As Range With Sheets("TABLA_DATOS") For Each celda In Sheets("PLANTILLA").Range("E7:E34") If Not celda = 0 Then .Range("A2").EntireRow.Insert .Range("A2") = Sheets("PLANTILLA").Range("D4") .Range("B2") = Sheets("PLANTILLA").Range("F3") .Range("C2") = Sheets("PLANTILLA").Range("I3") .Range("D2") = Sheets("PLANTILLA").Range("I4") .Range("E2") = Sheets("PLANTILLA").Cells(celda.Row, "E") .Range("F2") = Sheets("PLANTILLA").Cells(celda.Row, "D") .Range("G2") = Sheets("PLANTILLA").Cells(celda.Row, "C") .Range("H2") = Sheets("PLANTILLA").Cells(celda.Row, "B") .Range("I2") = Sheets("PLANTILLA").Cells(celda.Row, "A") End If Next End With Application.ScreenUpdating = True End Sub  
  15. Antoni's post in Añadir adjuntos a un correo segun rango de celdas was marked as the answer   
    Sobra un espacio en Range("A1:A ", prueba así:
    For Each archivo In Hoja4.Range("A1:A" & Hoja4.Range("A" & Rows.Count).End(xlUp).Row) .Attachments.Add archivo.Value, 1 Next  
  16. Antoni's post in For each me trae solo el primer registro was marked as the answer   
    Tranquila, nos ha pasado a todos 😂;
    ......
    .......
    evalua el tipo de registro si es huellas o fecas---------------------
        hD.Cells(uf, 10).Value = celda.Offset(0, 26)
        hD.Cells(uf, 23).Value = celda.Offset(0, 42)
        hD.Cells(uf, 12).Value = celda.Offset(0, 43)
       uf =uf +1
      End If
     
    Next celda
  17. Antoni's post in CARGA DETERMINADA LISTBOX A HOJA was marked as the answer   
    Sería algo así:
    With Sheets("CHECKIN") filaedit = 25 For i = 0 To UserForm1.ListBox2.ListCount - 1 .Cells(filaedit, "a") = UserForm1.ListBox2.List(i, 0) .Cells(filaedit, "o") = UserForm1.ListBox2.List(i, 1) .Cells(filaedit, "t") = UserForm1.ListBox2.List(i, 2) .Cells(filaedit, "z") = UserForm1.ListBox2.List(i, 3) filaedit = filaedit + 1 Next i End With  
  18. Antoni's post in Seleccionar y buscar de cuadro de lista excel NO USERFORM was marked as the answer   
    Ha sido más sencillo de lo previsto.
    Consultar Notificaciones.xlsm
  19. Antoni's post in Modificar rango de datos donde se copian datos filtrados was marked as the answer   
    Abre el adjunto y pulsa sobre cualquiera de las opciones de la hoja Categoria.
    Estas son las macros:
    Sub FiltroB(): Filtro "B- Menos de $1.000": End Sub Sub FiltroC(): Filtro "C- De $1.000 a $5.000": End Sub Sub FiltroD(): Filtro "D- De $5.000 a $15.000": End Sub Sub FiltroE(): Filtro "E- De $15.000 a $25.000": End Sub Sub FiltroF(): Filtro "F- De $25.000 a $50.000": End Sub Sub FiltroG(): Filtro "G- Más de $50.000": End Sub '------------------------------------------------------- Private Sub Filtro(Categoria As String) Application.ScreenUpdating = False Hoja4.Range("G14:N1600").ClearContents fila = 13 For x = 2 To Hoja1.UsedRange.Rows.Count If Hoja1.Range("C" & x) = Categoria Then fila = fila + 1 Hoja1.Range("A" & x).Resize(1, 9).Copy Hoja4.Range("G" & fila).PasteSpecial xlValues End If Next Application.CutCopyMode = False Hoja4.Activate End Sub  
    Pruebas (3).xlsm
  20. Antoni's post in CALCULAR HORAS TRABAJADAS SEGÚN FICHAJE was marked as the answer   
    Yo he interpretado que se trata de fichaje con entrada y salida y lo que se quiere es saber las horas trabajadas. En definitiva, hay que tratar las filas de 2 en 2, dando por supuesto que la  primera corresponde a la entrada y la segunda a la salida.
  21. Antoni's post in Código que sea mas rápido y consuma menos recursos en su ejecución was marked as the answer   
    Hoja1.Range("D" & Rows.Count).End(xlUp).Row  
  22. Antoni's post in ¿Cómo hago la consulta correcta sql de access desde excel para conocer el stok de cada producto en hoja? was marked as the answer   
    SQL = "SELECT SUM(IIF(MOVIMIENTO='ENTRADA',IZQ,IZQ*-1)) AS IZQ, SUM(IIF(MOVIMIENTO='ENTRADA',DER,DER*-1)) AS DER, MODELO FROM BASE GROUP BY MODELO"  
  23. Antoni's post in pasar una fila de 90 celdas a 10 filas de 9 celdas, con Range.find & VlookUp VBA was marked as the answer   
    Abre el adjunto y haz doble-click en cualquier celda del rango C9:C20 de la hoja CONSULTAS.
    No olvides subir tu archivo en futuras consultas, las imágenes no sirven para probar.
    CONSULTAS Y ENTREGAS.xlsm
×
×
  • Create New...

Important Information

Privacy Policy