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 (

Respuesta
1

. 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

Respuesta
2

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

  1. Abre tu libro de excel
  2. Para abrir VBa y poder pegar la función, Presiona Alt + F11
  3. En el menú elige Insertar / Módulo
  4. En el panel del lado derecho copia la función
  5. 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

.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas