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
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
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 SubPor 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 SubSlds
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
