concatenar datos automaticamente

[dragonfire33]

buenas como puedo mejorar este codigo para concatenear datos y enviarlos a la parte derecha como se muestra en la imagen

Sub Columnas()
On Error Resume Next
Application.ScreenUpdating = False
Range([AZ1].End(xlToLeft), [A1]).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete
F = [A1].CurrentRegion.Rows.Count
G = [A1].CurrentRegion.Columns.Count
For J = 1 To G
For i = 1 To F
                For x = 1 To Len(Cells(i, J))
                Y = Y & Mid(Cells(i, J), x, 1) & " "
                Next x
Cells(i, J + 200) = Trim(Y):    Y = "":
Next
Columns("AA:>N").Delete Shift:=xlToRight
Next
Range([AA1].End(xlToRight).Offset(0, -1), [AA1]).EntireColumn.Delete
FF = [A1].CurrentRegion.Rows.Count
GG = [A1].CurrentRegion.Columns.Count * 4
For Z = 0 To GG - 4 Step 4
Range(Cells(FF, Z + 27), Cells(2, Z + 27)).Borders.Item(xlEdgeLeft).LineStyle = xlContinuous
Range(Cells(FF, Z + 27), Cells(2, Z + 27)).TextToColumns Destination:=Cells(2, Z + 27), DataType:=xlDelimited, ConsecutiveDelimiter:=True, Other:=True, OtherChar:=" "
Next
With [AA1:CZ1]: .ColumnWidth = 3: .HorizontalAlignment = xlLeft: End With
Application.ScreenUpdating = True
End Sub

 

[offthelip]

Prueba esta:

Sub Columnas()
On Error Resume Next
Application.ScreenUpdating = False
Range([AZ1].End(xlToLeft), [A1]).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete
f = [A1].CurrentRegion.Rows.Count
g = [A1].CurrentRegion.Columns.Count
inarr = Range(Cells(1, 1), Cells(f, g))  ' Load Variant array
For J = 1 To g
For i = 1 To f
'                For x = 1 To Len(Cells(i, J))
                For x = 1 To Len(inarr(i, J))
'                Y = Y & Mid(Cells(i, J), x, 1) & " "
                Y = Y & Mid(inarr(i, J), x, 1) & " "
                Next x
Cells(i, J + 200) = Trim(Y):    Y = "":
Next
Columns("AA:>N").Delete Shift:=xlToRight
Next
Range([AA1].End(xlToRight).Offset(0, -1), [AA1]).EntireColumn.Delete
FF = [A1].CurrentRegion.Rows.Count
GG = [A1].CurrentRegion.Columns.Count * 4
For Z = 0 To GG - 4 Step 4
Range(Cells(FF, Z + 27), Cells(2, Z + 27)).Borders.Item(xlEdgeLeft).LineStyle = xlContinuous
Range(Cells(FF, Z + 27), Cells(2, Z + 27)).TextToColumns Destination:=Cells(2, Z + 27), DataType:=xlDelimited, ConsecutiveDelimiter:=True, Other:=True, OtherChar:=" "
Next
With [AA1:CZ1]: .ColumnWidth = 3: .HorizontalAlignment = xlLeft: End With
Application.ScreenUpdating = True
End Sub

 

[dragonfire33]

no me funciona como espero a que se debe?

 

[DanteAmor]

Siguiendo con tu imagen de ejemplo.
Si tus datos empiezan en la celda B2 y terminan en la columna AA

Lo siguiente pone los resultados en la columna AD.
Nota: No elimina columnas ni pone el formato, pero supongo que a partir de este punto puedes eliminar las columnas al final de la macro y aplicar el formato que necesitas.

Sub ConcatenarDatos()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, n As Long
 
  a = Range("B2:AA" & ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row).Value
  ReDim b(1 To UBound(a, 1), 1 To 26 * 4)
 
  For i = 1 To UBound(a, 1)
    n = 0
    For j = 1 To UBound(a, 2)
      For k = 1 To 4
        n = n + 1
        b(i, n) = Mid(a(i, j), k, 1)
      Next
      If j Mod 2 = 0 Then j = j + 2
    Next
  Next
  Range("AD2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

Recomendación: No utilices la instrucción "On Error Resume Next", si tu macro tiene algún error, simplemente continuará y no sabrás cuál es el problema. Lo recomendable es utilizar código para detectar los posibles errores.

 

[dragonfire33]

Siguiendo con tu imagen de ejemplo.
Si tus datos empiezan en la celda B2 y terminan en la columna AA

Lo siguiente pone los resultados en la columna AD.
Nota: No elimina columnas ni pone el formato, pero supongo que a partir de este punto puedes eliminar las columnas al final de la macro y aplicar el formato que necesitas.

Sub ConcatenarDatos()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, n As Long
 
  a = Range("B2:AA" & ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row).Value
  ReDim b(1 To UBound(a, 1), 1 To 26 * 4)
 
  For i = 1 To UBound(a, 1)
    n = 0
    For j = 1 To UBound(a, 2)
      For k = 1 To 4
        n = n + 1
        b(i, n) = Mid(a(i, j), k, 1)
      Next
      If j Mod 2 = 0 Then j = j + 2
    Next
  Next
  Range("AD2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

Recomendación: No utilices la instrucción "On Error Resume Next", si tu macro tiene algún error, simplemente continuará y no sabrás cuál es el problema. Lo recomendable es utilizar código para detectar los posibles errores.

Listo dante anotada su recomendación para la próxima muchas gracias y dante que línea debería agregar con formato 14 a la macro

 

[DanteAmor]

Probaste la macro?
Funciona la distribución de números tal y como la necesitas?
A qué te refieres con "formato 14"?

 

[dragonfire33]

Dante el código funciona bien pero solo concatena de a 2 columnas intermedias,
Me explico concatena la columna A y B pero C y D no E y F si pero G y H no lo hace a qué se debe

 

[DanteAmor]

Puedes actualizar tu imagen.
En tu imagen, los datos empiezan en la columna B.
Y luego en tu imagen van de 2 en 2, 2 columnas con números, 2 columnas en blanco.

La macro está basada en tu imagen.

Si vas a tener datos en todas las columnas, entonces tu ejemplo debe estar basado en esa realidad.

Prueba el siguiente:

Sub ConcatenarDatos()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, n As Long
  
  a = Range("A2:AA" & ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row).Value
  ReDim b(1 To UBound(a, 1), 1 To 27 * 4)
  
  For i = 1 To UBound(a, 1)
    n = 0
    For j = 1 To UBound(a, 2)
      For k = 1 To 4
        n = n + 1
        b(i, n) = Mid(a(i, j), k, 1)
      Next
    Next
  Next
  Range("AD2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

 

[dragonfire33]

gracias dante

 

[DanteAmor]

Encantado de ayudarte.
Gracias por comentar.