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