Macro para separar datos en una misma hoja según criterio

Quisiera saber si puede darme soporte con una macro, si es viable mi caso que pongo a continuación, lo cual hago de manera manual:

El recuadro encerrado en rojo es donde empiezo mi proceso.

En la imagen detallo la idea.

Me mantengo atento a su valioso aporte.

Gracias.

4 Respuestas

Respuesta
2

Te muestro la pantalla con el resultado final y abajo de esta se encuentra la macro

esta es la macro

Sub copiar()
Set datos = Range("i1").CurrentRegion
Dim numeros As New Collection
Dim textos As New Collection
With datos
    For i = 1 To .Cells.Count
        valor = .Cells(i)
        If IsNumeric(valor) = True Then numeros.Add valor
        If IsNumeric(valor) = False Then textos.Add valor
    Next i
    Set stextos = Range("a2").Resize(numeros.Count / 5, 5)
    Set snumeros = Range("a18").Resize(stextos.Count / 5, 5)
    For j = 1 To textos.Count:   stextos.Cells(j) = textos.Item(j):    Next j
    For k = 1 To numeros.Count:  snumeros.Cells(k) = numeros.Item(k): Next k
    snumeros.CurrentRegion.NumberFormat = "0000000000000"
End With
End Sub
Respuesta
1

Te envío la macro solicitada!

Sub Macro1()
'
Dim LoopRow As Integer
Dim LoopColumn As Integer
Dim Valor As String
Dim Comienzo As String
Dim CodX As Integer
Dim CodY As Integer
Dim NumX As Integer
Dim NumY As Integer
Set DataSH = Sheets("Data") 'Hoja para trabajar
FR = 7 'Fila en la que comienza la Data
FC = 8 'Columna en la que comienza la Data
CodX = 11 'Fila en la que comienza a colocar los Codigos
NumX = 50 'Fila en la que comienza a colocar los Numeros
LastRow = DataSH.Cells(DataSH.Rows.Count, FC).End(xlUp).Row
LastColumn = DataSH.Cells(FR, DataSH.Columns.Count).End(xlToLeft).Column
CodY = 1
NumY = 1
LoopRow = FR
Do Until LoopRow > LastRow
    LoopColumn = FC
    Do Until LoopColumn > LastColumn
    Valor = DataSH.Cells(LoopRow, LoopColumn).Value
    Comienzo = UCase(Left(Valor, 1))
    If Comienzo = "T" Then
        If CodY > 5 Then
        CodX = CodX + 1
        CodY = 1
        End If
        DataSH.Cells(CodX, CodY).Value = Valor
        CodY = CodY + 1
    Else
        If NumY > 5 Then
        NumX = NumX + 1
        NumY = 1
        End If
        DataSH.Cells(NumX, NumY).Value = Valor
        NumY = NumY + 1
    End If
    LoopColumn = LoopColumn + 1
    Loop
LoopRow = LoopRow + 1
Loop
End Sub

Por favor recuerda valorar la respuesta!

SLDS

Juan

Estimado la macro esta bien, pero como se le pone un código para que no te borre los ceros adelante?? en la fila 50 pasa las series numéricas pero sin los 3 ceros.

Eso es por que los reconoce como números y EXCEL le elimina los 0 a la izquierda

Proba agregándoles "'" adelante a los números, de esta manera los tomara como string.

Te envío la macro final

Sub Macro1()
'
Dim LoopRow As Integer
Dim LoopColumn As Integer
Dim Valor As String
Dim Comienzo As String
Dim CodX As Integer
Dim CodY As Integer
Dim NumX As Integer
Dim NumY As Integer
Set DataSH = Sheets("Data") 'Hoja para trabajar
FR = 7 'Fila en la que comienza la Data
FC = 8 'Columna en la que comienza la Data
CodX = 11 'Fila en la que comienza a colocar los Codigos
NumX = 50 'Fila en la que comienza a colocar los Numeros
LastRow = DataSH.Cells(DataSH.Rows.Count, FC).End(xlUp).Row
LastColumn = DataSH.Cells(FR, DataSH.Columns.Count).End(xlToLeft).Column
CodY = 1
NumY = 1
LoopRow = FR
Do Until LoopRow > LastRow
    LoopColumn = FC
    Do Until LoopColumn > LastColumn
    Valor = DataSH.Cells(LoopRow, LoopColumn).Value
    Comienzo = UCase(Left(Valor, 1))
    If Comienzo = "T" Then
        If CodY > 5 Then
        CodX = CodX + 1
        CodY = 1
        End If
        DataSH.Cells(CodX, CodY).Value = Valor
        CodY = CodY + 1
    Else
        If NumY > 5 Then
        NumX = NumX + 1
        NumY = 1
        End If
        DataSH.Cells(NumX, NumY).Value = "'" & Valor
        NumY = NumY + 1
    End If
    LoopColumn = LoopColumn + 1
    Loop
LoopRow = LoopRow + 1
Loop
End Sub

Slds

Respuesta
1

Visita http://programarexcel.com descarga cientos de ejemplos de macros gratis.

Suscribe a https://youtube.com/programarexcel recibirás en tu mail las actualizaciones

Hola amigo prueba estas macros de ejemplo que te permiten recorre celdas y hacer que excel haga lo que requieres

https://youtu.be/qtkrkNVxsuQ

https://youtu.be/HjuSns2xJ5Y

https://youtu.be/hJHTspgfavI

https://youtu.be/V_pQbeDdlFY

Respuesta
1

Enviame el archivo

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas