Jump to content

Antoni

Members
  • Posts

    11,373
  • Joined

  • Last visited

  • Days Won

    799

Posts posted by Antoni

  1. Esta macro te permite seleccionar cualquier número de días y empleados.

    Permite selecciones discontinuas.

    Para ver como funciona, abre el adjunto y ejecuta la macro respetando la selección.

    Sub aBaseDeDatosSelección()
    With Sheets("DeCuaABase")
       .Range("A8").CurrentRegion.Offset(1).ClearContents
       fila = 8
       For Each rango In Selection.Areas
          For y = rango.Column To rango.Columns.Count + rango.Column - 1
             For x = rango.Row To rango.Rows.Count + rango.Row - 1
                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
       Next
    End With
    Application.ScreenUpdating = True
    End Sub

     

    deCuaABAse.xlsm

  2. 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

     

  3. El foro no es un chat, ni un lugar de formación, en el se resuelven consultas concretas a problemas concretos.

    Tu consulta ha sido resuelta, cualquier otra cuestión pasa por abrir una consulta nueva, adjuntando un archivo Excel con un ejemplo de lo que tienes y de lo que pretendes conseguir.

    Esta consulta, se da por finalizada.

     

  4. Hace 1 hora, questionAbout dijo:

    Siempre he tenido una duda, y me gustaría aprovechar que usted es un experto para preguntar, con este tipo de filtros, es posible agregar no sé si característica o variable, pero que sin importar la ortografía el buscados encuentre resultado?... Por ejemplo el producto se llama zapato pero yo lo busco sapato, es posible agregar esa propiedad al buscador ?

    No, no es posible, salvo que hicieras una hoja de equivalencias con dos columnas donde buscar el texto correcto.

     

  5. Suponiendo que tus datos área, proveedor, producto y precio están en las columnas A,B,C y D respectivamente y los textbox se llaman txtFiltro1,txtFiltro2,txtFiltro3 y txtFiltro4, respectivamente. 

    Elimina el textbox txtFiltro y añade los  textbox txtFiltro1,txtFiltro2,txtFiltro3 y txtFiltro4.

    Añade un botón con el nombre BotónBuscar.

    Private Sub BotónBuscar_Click()
    Dim x As Long
    Aviso = ""
    With ListBox1
       .Clear
       For x = 2 To Hoja1.Range("A" & Rows.Count).End(xlUp).Row
          If UCase(txtFiltro1) Like "*" & UCase(Hoja1.Range("A" & x)).Text & "*" And _
             UCase(txtFiltro2) Like "*" & UCase(Hoja1.Range("B" & x)).Text & "*" And _
             UCase(txtFiltro3) Like "*" & UCase(Hoja1.Range("C" & x)).Text & "*" And _
             UCase(txtFiltro4) Like "*" & UCase(Hoja1.Range("D" & x)).Text & "*" Then
             .AddItem
             .List(.ListCount - 1, 0) = Hoja1.Range("A" & x).Text
             .List(.ListCount - 1, 1) = Hoja1.Range("B" & x).Text
             .List(.ListCount - 1, 2) = Hoja1.Range("C" & x).Text
             .List(.ListCount - 1, 3) = Hoja1.Range("D" & x).Text
          End If
       Next
       Aviso.ForeColor = vbBlack
       If .ListCount = 0 Then
           Aviso.ForeColor = vbRed
           Aviso = "*** SIN RESULTADO ***"
       Else
           Aviso = .ListCount & " registros"
       End If
    End With
    End Sub

     

  6. Sub CompararPrecios()
    Dim celda As Range, factura As Worksheet, x As Long
    Dim precio As Worksheet, resultado As Worksheet, fila As Long
    '--
    Application.ScreenUpdating = False
    Set factura = Sheets("factura")
    Set precio = Sheets("precio")
    Set resultado = Sheets("resultado")
    '--
    With precio
       .Range(.Range("B1"), .Range("B1").End(xlDown)).Interior.ColorIndex = xlNone
    End With
    resultado.Cells.ClearContents
    With factura
       .Range(.Range("B1"), .Range("B1").End(xlDown)).Interior.ColorIndex = xlNone
       For x = 1 To .Range("A" & Rows.Count).End(xlUp).Row
          Set celda = precio.Columns("A").Find(.Range("A" & x))
          If Not celda Is Nothing Then
             If Not .Range("B" & x) = celda.Offset(, 1) Then
                .Range("B" & x).Interior.Color = vbYellow
                celda.Offset(, 1).Interior.Color = vbYellow
                fila = fila + 1
                resultado.Range("A" & fila) = .Range("A" & x)
                resultado.Range("B" & fila) = .Range("B" & x)
                resultado.Range("C" & fila) = celda.Offset(, 1)
             End If
          End If
       Next
    End With
    '--
    If fila = 0 Then
       MsgBox "*** SIN INCIDENCIAS ***", vbInformation
    Else
       MsgBox "*** DETECTADAS " & fila & " INCIDENCIAS ***", vbExclamation
       resultado.Select
    End If
    End Sub

     

    Comparacion.xlsm

  7. 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

     

  8. Esta función compara palabras y puedes usarla así:  =ComparaNombre(A2;B2)

    Function ComparaNombre(A As String, B As String) As Boolean
    a1 = Split(A, " ")
    b1 = Split(B, " ")
    If UBound(a1) = UBound(b1) Then
       For x = 0 To UBound(a1)
          For y = 0 To UBound(b1)
             If UCase(a1(x)) = UCase(b1(y)) Then t = t + 1
          Next
       Next
       If t = UBound(a1) + 1 Then ComparaNombre = True
    End If
    End Function

     

  9. Hace 7 horas, Abraham Valencia dijo:

    Hola

    Las constantes públicas solo pueden ser declaradas en módulos estándar y es seguro que estás intentando declararlas en un módulo de Clase, no olvidando que los módulos de las hojas, el libro y los Userform son de Clase.

    Saludos

    Efectivamente, tal como se ve en tu imagen, estás dentro de un módulo de hoja. (Se observa Private Sub Worksheet_Activate())

  10. Prueba con esta macro:

    Sub ÚltimaFecha()
    fecha = InputBox("Introduzca fecha a buscar (dd/mm/aaaa)")
    If IsDate(fecha) Then
       fecha = CDate(fecha)
       For x = Hoja1.Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
          If Hoja1.Range("A" & x) = fecha Then
             Hoja1.Range("A" & x).Select
             MsgBox "Fecha " & fecha & " encontrada en la fila " & x, vbInformation
             Exit Sub
          End If
       Next
       MsgBox "La fecha " & fecha & " no existe", vbExclamation
    End If
    End Sub

     

×
×
  • Create New...

Important Information

Privacy Policy