جرب هذا الماكرو
Option Explicit
Sub All_in_on()
With Sheets("sheet1")
Dim my_rg As Range, N_col%, N_Row%, x%
Dim t%, k%: k = 2
Set my_rg = .Range("a2").CurrentRegion
.Range("j2", Range("j1").End(4)).ClearContents
N_col = my_rg.Columns.Count
N_Row = my_rg.Rows.Count
For x = 1 To N_col
For t = 1 To N_Row
If Not IsEmpty(my_rg.Cells(t, x)) Then
.Cells(k, "J") = my_rg.Cells(t, x)
k = k + 1
End If
Next
Next
End With
End Sub
الملف مرفق
Write_in_one_col.xlsm