Macro que inserte datos en orden según el código que tenga.

Tengo 2 columnas. La primera De Código y la segunda es de Cuentas. Con un formulario quiero que al ingresar una cuenta nueva con su código, (EJEMPLO: "1.1.01" "Hojas de papel" o´ "1.1" "Cartas" ó "1.1.01.01" "Barcos" ó "2.1" "Arroz" ó "2.1.01.01" "Carro" ó "1.1.01.02" "Torres") la cuenta se ubique en el orden que debe según el código que tiene!

1.1            Cartas

1.1.01       Hojas de papel

1.1.01.01 Barcos

1.1.01.02 Torres

2.1            Arroz

2.1.01.01 Carro

1 Respuesta

Respuesta
2

H o l a : Te anexo la macro.

En tu hoja "cuentas", las cuentas deberán empezar en la fila 2 y en la fila 1 deberás tener el encabezado. Con tu formulario deberás agregar el nuevo registro al final de la lista, como se muestra en la imagen.

Después de agregar el registro, ejecuta la macro OrdenarCuentas, desde tu formulario pon:

Call OrdenarCuentas

De preferencia pon la macro dentro del código del formulario.

Sub OrdenarCuentas()
'Por.Dante Amor
    Application.ScreenUpdating = False
    Set h1 = Sheets("cuentas")
    Set h2 = Sheets("temp")
    h2.Cells.Clear
    h1.Columns("A").Copy h2.[A1]
    h2.Columns("A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, _
        OtherChar:=".", _
        FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2), Array(4, 2), _
                         Array(5, 2), Array(6, 2), Array(7, 2), Array(8, 2), _
                         Array(9, 2), Array(10, 2)), _
        TrailingMinusNumbers:=True
    h1.Columns("B").Copy h2.[K1]
    '
    u = h2.Range("A" & Rows.Count).End(xlUp).Row
    h2.Range("A2:J" & u).SpecialCells(xlCellTypeBlanks) = "'0"
    h2.Range("B1:J1") = Array("N2", "N3", "N4", "N5", "N6", "N7", "N8", "N9", "N10")
    '
    With h2.Sort
        .SortFields.Clear
        For i = 1 To 10
            .SortFields.Add Key:=h2.Range(h2.Cells(2, i), h2.Cells(u, i)), _
                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
                xlSortTextAsNumbers
        Next
        .SetRange h2.Range("A1:K" & u)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    For i = 2 To u
        cad = "'"
        For j = 1 To 10
            If h2.Cells(i, j) <> "0" Then
                cad = cad & h2.Cells(i, j) & "."
            End If
        Next
        If cad <> "" Then
            cad = Left(cad, Len(cad) - 1)
            h2.Cells(i, "L") = cad
        End If
    Next
    h2.Range("L2:L" & u).Copy h1.[A2]
    h2.Range("K2:K" & u).Copy h1.[B2]
    Application.ScreenUpdating = True
End Sub

La macro tiene capacidad para cuentas de hasta 10 niveles, por ejemplo 1.1.0.0.1.6.7.8.9.10

Antes de ejecutar la macro deberás crear una hoja con el nombre "temp".

Cambia en la macro "cuentas" por el nombre de la hoja que tiene las cuentas.

'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas