Saltar al contenido
Conéctate para seguir esto  
pedrot

Encontrar grupos iguales y sumarlos

Recommended Posts

Buenas tardes, noche o día Excel_entes

Necesito detectar una serie de grupos de elementos que sean iguales. La ventaja es que esos grupos afortunadamente siempre están juntos y su último elemento tiene una ‘x’

Esta serie de elementos son vigas marcadas, ej.: w-RF-45, que tienen cantidad y longitud. El programa toma esas longitudes y trata de formar la mejor distribución que sea la mayor suma y menor o igual que una longitud dada, ej.: 12050mm. La macro que contiene para la agrupación es manual? Su instrucción está en el archivo. Debe detectar los iguales y cuántos son.

Comprimir iguales.xlsm

Compartir este mensaje


Enlace a mensaje
Compartir con otras webs

Saludos  de nuevo

esta es la rutina que intenté:

Sub comprime()
'
Dim ra() As String
Dim aa, rb As String

Dim a1 As Double

aa = "-"
i = 1: j = 0
Range("A7").Select
While aa <> "***"
vuelve:
    If ActiveCell().Value <> "" And ActiveCell().Value <> "***" Then
        While ActiveCell().Value <> ""
            j = j + 1
            On Error GoTo aqui
            a1 = WorksheetFunction.Find("x", ActiveCell().Value)
            '  If a1 <> 0 Then
            i = i + 1
            aa = ActiveCell().Value
            GoTo aqui1
            '  End If
        Wend
aqui:
        On Error GoTo -1
        ra(i, j) = ActiveCell().Value
        ReDim Preserve ra(i, j) As String
        ActiveCell.Offset(1, 0).Select
        aa = ActiveCell().Value
        GoTo vuelve
    End If
aqui1:
    j = 0
    aa = ActiveCell().Value
    ActiveCell.Offset(1, 0).Select
Wend
End Sub

Me rendí .......

Compartir este mensaje


Enlace a mensaje
Compartir con otras webs

Saludos Excel_entes

Me olvide de la "x" como referencia pasa saber donde terminaba cada grupo y quedó así:

Public CantPiezas, CantGrupos As Integer

Sub comprime() '******
'
'''############################
'  Para agrupar los iguales
'  Acceso directo: Ctrl+Mayús+P
'  AyudaExcel > Pedrot
'''############################
'
Dim grupo() As String
Dim aa, rb As String
Dim a1, a2 As Integer
i = 1: j = 0: k = 0: a1 = 0
Range("A7").Select
aqui0:
While ActiveCell() <> "***"
    While ActiveCell() <> ""
        fila = ActiveCell().Row
        Nfila = Range("A" & ActiveCell().Row).End(xlDown).Row - fila
        ReDim Preserve grupo(Nfila)
        For j = 1 To Nfila
            grupo(j) = ActiveCell().Value
            ActiveCell.Offset(1, 0).Select
        Next j
        ActiveCell.Offset(2, 0).Select
        If ActiveCell().Value <> "***" Then   '
            While a1 = 0
                Nfila2 = Range("A" & ActiveCell().Row).End(xlDown).Row - ActiveCell().Row
                If Nfila = Nfila2 Then
                    For jj = 1 To Nfila2
                        If grupo(jj) = ActiveCell().Value Then
                            ActiveCell.Offset(1, 0).Select
                        Else
                            GoTo aqui1
                        End If
                    Next jj
                    k = k + 1
                    ActiveCell.Offset(2, 0).Select
                Else
                    a1 = 1
                    jj = 1
                End If
            Wend
aqui1:
            a1 = 0
            ActiveCell.Offset(-jj + 1, 0).Select
            If k > 0 Then
                Range("A" & fila).Select
                CantPiezas = j - 1
                CantGrupos = k + 1
                Call borragrupos      ' Borra lineas
                k = 0
            End If
            GoTo aqui0
        Else
          Exit Sub
        End If
    Wend
    ActiveCell.Offset(1, 0).Select
Wend
End Sub


Sub borragrupos()
    nViga = ActiveCell.Offset(CantPiezas, 7).Value * CantGrupos
    NoSelec = CantPiezas + 2
    TotalSelec = NoSelec * (CantGrupos - 1) - 1
    Range(ActiveCell(), ActiveCell().Offset(TotalSelec, 7)).Select
    Selection.Delete Shift:=xlUp
    ActiveCell().Select
    ActiveCell.Offset(CantPiezas, 0).Value = nViga & " x " & "12050" '  Range("longAlmacen")
    For i = 0 To CantPiezas - 1
        ActiveCell.Offset(i, 3).Value = nViga
    Next i
    ActiveCell.Offset(i, 4).Value = nViga
    ActiveCell.Offset(i, 7).Value = nViga
End Sub

A tracción de sangre ... pero funsiona

Resuelto

Compartir este mensaje


Enlace a mensaje
Compartir con otras webs

Crear una cuenta o conéctate para comentar

Necesitas ser usuario para poder dejar un comentario

Crear una cuenta

Registrarse para una nueva cuenta en nuestra comunidad. ¡Es fácil!

Registrar una nueva cuenta

Conectarse

¿Ya tienes una cuenta? Conéctate aquí.

Conéctate ahora

Conéctate para seguir esto  

×