السلام عليكم
أخى الفاضل / سعد عابد
تفضل ما تريد
Sub ragab()
Dim i As Integer
Dim x As Integer
Dim LR As Integer
Dim cl As Range
Dim arr() As Variant
'=========================================
Set WF = Application.WorksheetFunction
'=========================================
For x = 0 To 2
LR = Cells(Rows.Count, x + 1).End(xlUp).Row
For Each cl In Range("A1:A" & LR).Offset(0, x)
If Not IsEmpty(cl) Then
i = i + 1
ReDim Preserve arr(1 To i)
arr(i) = cl
End If
Next
Range("A1").Offset(0, x).Resize(LR).ClearContents
Range("A1").Offset(0, x).Resize(i) = WF.Transpose(arr)
Erase arr
i = 0
Next
End Sub
ازالة الفراغات2.rar