Necesito sacar datos de una columna y ponerlos en otra pero con una serie especifica
Necesito sacar los datos de la columna A.B.C.D.E.F.G y ponerlos en las celdas que que corresponda por su categoria pero ordenados de menor a mayor, sin los ceros y separados por comas (
. 27.04.17 #VBA Registro ordenado por burbuja
Buenas noches, Alan
Hay preguntas a las que respondo porque entiendo que sé la solución.
En cambio, hay otras que respondo -precisamente- por que no la sé. Y estas son las que más me gustan porque me obligan a aprender.
La tuya hubiese estado dentro de las primeras... si no hubieses pedido que el resultado saliese ordenado de menor a mayor.
Ví que ya obtuviste una respuesta del generoso Dante, pero me permito proponerte otra alternativa. Es una de las bondades de MS Excel y VBA que permiten múltiples soluciones a un mismo problema.
Esta variante se trata de un código que sólo necesita que le digas dónde empieza tu cuadro de números (en tu ejemplo la celda "A1") y donde quieres que empiece a dejar los valores (I2).
Luego la rutina se encarga de ver cuantas categorías hay y no importa hasta qué fila esté ocupada cada columna.
Para probarla, accede al Editor de VBA (Atajo: Alt + F11), allí inserta un módulo (Insertar-Módulo) y pega el siguiente código:
Option Base 1 Sub TrasponCat() '---- Variables modificables ---- '=== ALAN, modifica estos datos de acuerdo a tu proyecto: IniCuadro = "A1" 'celda donde inicia el cuadro a traponer IniDest = "I2" ' celda donde iniciar la trasposición de datos. '---- fin Variables ' ' VBA coding by FeJoAl ' '---- inicio de rutina: ' Dim ListaNums() CantCols = Range(IniCuadro).CurrentRegion.Columns.Count For LaColu = 0 To CantCols - 1 LaFila = 0 Elemento = 1 TitCat = Range(IniCuadro).Offset(LaFila, LaColu).Value 'carga de números a ordenar ' LaFila = 1 Do While Not IsEmpty(Range(IniCuadro).Offset(LaFila, LaColu)) If Range(IniCuadro).Offset(LaFila, LaColu).Value <> 0 Then ReDim Preserve ListaNums(Elemento + 1) ListaNums(Elemento) = Range(IniCuadro).Offset(LaFila, LaColu).Value Elemento = Elemento + 1 End If LaFila = LaFila + 1 Loop 'Ordenamiento por Método de Burbuja ' CantNums = UBound(ListaNums) - 1 For PrimEle = 1 To CantNums - 1 For SigEle = PrimEle + 1 To CantNums If ListaNums(PrimEle) > ListaNums(SigEle) Then auxiliar = ListaNums(PrimEle) ListaNums(PrimEle) = ListaNums(SigEle) ListaNums(SigEle) = auxiliar End If Next SigEle Next PrimEle 'Contrucción del registro ordenado y transpuesto ' ElTexto = "" Eleme = 0 For Eleme = 1 To UBound(ListaNums) - 1 ElTexto = Trim(ElTexto & IIf(Eleme = 1, "", ",") & ListaNums(Eleme)) Next Range(IniDest).Offset(LaColu, 0).Value = TitCat Range(IniDest).Offset(LaColu, 1).Value = ElTexto cont = cont + 1 Next 'Mensaje final ' ElMensaje = IIf(cont = 0, "NO SE TRASLADO COLUMNA ALGUNA", "Se generaron: " & cont & " linea" & IIf(cont > 1, "s", "")) TipoMens = IIf(cont = 0, vbCritical, vbInformation) ElTitulo = IIf(cont = 0, "NO SE HIZO NADA", "TERMINADO!") Application.ScreenUpdating = True MsgBox ElMensaje, TipoMens, ElTitulo End Sub
Espero que te sirva para tu objetivo.
Saludos
Fernando
.
¡Gracias! Herma este foro no me da chance para responder todos conocen mucho de algo pero espero algun dia ayudar como ustedes a mi gracias
.
Bien, Alan
Ten en cuenta que todos empezamos como tú, sin saber tanto. Es una cuestión de constancia, curiosidad y la necesidad de resolver algún problema -en este caso- con MS Excel. Luego sumale tiempo y verás los resultados.
Recuerda, valorar esta respuesta para que quede finalizada.
Un abrazo
Fer
.
¡Gracias!
.
Un placer, Alan
Abajo tienes un botón de opciones para valorar las respuestas, ya sabes.
Abrazo
Fer
.
.
Hola, Alan
Noto que aún sigue pendiente esta consulta.
Disculpa que insista, pero -por favor- valorízala para que quede cerrada.
Abrazo
Fer
.
1 respuesta más de otro experto
Te anexo una función.
Dim num As New Collection ' Function ConcatenaNum(celdas As Range) 'Por.Dante Amor For Each n In celdas If IsNumeric(n) And n <> 0 Then Call agregar(n) End If Next ' For Each n In num cad = cad & "," & n Next If cad <> "" Then cad = Mid(cad, 2) ConcatenaNum = cad Set num = Nothing End Function ' Sub agregar(dato) 'Por.Dante Amor dato = "" & dato For i = 1 To num.Count Select Case StrComp(num(i), dato, vbTextCompare) Case 0, 1: num.Add dato, Before:=i: Exit Sub 'agrega antes End Select Next num.Add dato 'lo agrega al final End Sub
Sigue las Instrucciones para una Función
- Abre tu libro de excel
- Para abrir VBa y poder pegar la función, Presiona Alt + F11
- En el menú elige Insertar / Módulo
- En el panel del lado derecho copia la función
- En cualquier celda utiliza la función, como cualquier otra función de excel
Por ejemplo, en la celda J2, pon la siguiente función:
=ConcatenaNum(A2:A12)
En la celda J3, pon la siguiente función:
=ConcatenaNum(B2:B12)
Y así, hacia abajo pon la función y el rango de celdas que quieras
El resultado quedaría así:
.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
Avísame cualquier duda
.
Gracias por el cumplido! - Dante Amor
Dante: Para alguien que dio -y sigue dando- más de 15.000 respuestas, generoso es hasta escaso para decirte. Sigue con tu muy buen aporte. Saludos. Fer - fejoal