Se necesita soporte con una macro
Dante me apoyo con esta macro para rellenar series, lo que pasa que cuando mis series empiezan con una caracter de letras adelante funciona OK, pero tengo series que empiezan con 3 ceros "000***" Al ejecutarla me borra los ceros, quisiera un soporte en adicionar un código
Adjunto aporte si Dante me puedes ayudar genial.
Gracias.
Sub CopiarSeries()
'Por.Dante Amor
Application.ScreenUpdating = False
ActiveSheet.UsedRange.Offset(0, 7).ClearContents
Serie = 5
j = 1
For i = 1 To Range("A" & Rows.Count).End(xlUp).Row Step Serie
Range(Cells(i, "A"), Cells(i + Serie - 1, "A")).Copy
Cells(j, "K").PasteSpecial Transpose:=True
For k = Columns("K").Column To Columns("K").Column + Serie
c = Columns("K").Column + Serie + 1
Cells(j, c) = Cells(j, c) & " " & Cells(j, k)
Next
j = j + 1
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
'MsgBox "Fin"para que me pase en el formato que necesito.
2 respuestas
Respuesta de Elsa Matilde
3
Respuesta de James Bond
2
Prueba con la macro abajo de la imagen con el resultado final
Sub MACRO()
Dim NUMEROS As New Collection
Dim TEXTOS As New Collection
Set datos = Range("A1").CurrentRegion
With datos
For I = 1 To .Rows.Count
Valor = .Cells(I, 1)
If IsNumeric(Valor) = True Then NUMEROS.Add Valor
If IsNumeric(Valor) = False Then TEXTOa.Add Valor
Next I
Set area = .Columns(.Columns.Count + 2).Resize(NUMEROS.Count, 1)
Set area2 = .Columns(.Columns.Count + 3).Resize(TEXTOS.Count, 1)
area.Resize(1000, 1000).ClearContents
End With
For I = 1 To NUMEROS.Count: area.Cells(I, 1) = NUMEROS.Item(I): Next I
For I = 1 To TEXTOS.Count: area2.Cells(I, 1) = TEXTOS.Item(I): Next I
area.CurrentRegion.EntireColumn.AutoFit
filas = WorksheetFunction.Quotient(TEXTOS.Count, 5)
RESTOS = TEXTOS.Count Mod 5: If RESTOS < 5 Then RESTOS = 1
Tfilas = filas + RESTOS
Set INFO = area2.Columns(area2.Columns.Count + 3).Resize(Tfilas, 1)
SALIR = False
REGRESA:
For J = 1 To Tfilas
If J = 1 Then Set area2 = area2.Resize(5, 1)
If J > 1 Then Set area2 = area2.Rows(6).Resize(5, 1)
For K = 1 To 5
Valor = area2.Cells(K, 1)
If Valor = Empty Then Exit For
If IsNumeric(Valor) = True Then
Valor = WorksheetFunction.Text(Valor, "0000000000000")
End If
If K = 1 Then conca = Valor
If K > 1 Then conca = conca & " " & Valor
Next K
INFO.Cells(J, 1) = conca
Next J
If RESTOS = 1 And IsNumeric(INFO.Cells(J - 1, 1)) = True Then
INFO.Cells(J - 1, 1).NumberFormat = "0000000000000"
End If
Set area2 = area
filas = WorksheetFunction.Quotient(NUMEROS.Count, 5)
RESTOS = NUMEROS.Count Mod 5:
Tfilas = filas + RESTOS
INFO.EntireColumn.AutoFit
INFO.HorizontalAlignment = xlLeft
filas = WorksheetFunction.Quotient(NUMEROS.Count, 5)
RESTOS = NUMEROS.Count Mod 5: If RESTOS < 5 Then RESTOS = 1
Tfilas = filas + RESTOS
Set INFO = INFO.Columns(INFO.Columns.Count + 2).Resize(Tfilas, 1)
If SALIR = False Then SALIR = True: GoTo REGRESA:
Set area2 = area2.CurrentRegion
area2.Resize(area2.Rows.Count, 4).EntireColumn.Delete
End Sub
No importa si los datos iniciales están mezclados la macro los separa