السلام عليكم
كود الترحيل
Sub kh_Start()
Dim x
Dim Cont As Integer, M As Integer, Z As Integer
Dim r As Integer, rr As Integer, c As Integer, cc As Integer
1:
x = InputBox("ادخل عدد الارقام . ")
If x = Cancel Then Exit Sub
x = Val(x)
If x = 0 Then GoTo 1
Cont = Abs(Int(-x / 30))
M = x Mod 30
rr = 1
Z = 30
Sheets("02").UsedRange.ClearContents
For r = 1 To x Step 30
c = c + 1
cc = cc + 1
If cc = Cont Then If M Then Z = M
Sheets("02").Cells(rr, c).Resize(Z, 1).Value = Sheets("01").Cells(r, 1).Resize(Z, 1).Value
If c = 7 Then c = 0: rr = rr + 30
Next
End Sub
كود المسح
Sub kh_Clear()
Sheets("02").UsedRange.ClearContents
End Sub
شاهد المرفق 2010
ترحيل الى جدول.rar