ترحيل من ورقة1 الى ورقة 2

[رشوان احمد]

الاخوة الافاضل

ممكن ترحيل من ورقة1 الى ورقة 2

بشرط ترحيل نهاية المادة مثل الجدول فى الورقة 2

المطلوب بالملف الملحق

ترحيل.rar

تم تعديل ديسمبر 14, 2012 بواسطه رشوان احمد

[أبو حنــــين]

السلام عليكم

جرب أخي المرفق

ترحيل.rar

[الـعيدروس]

السلام عليكم

تفضل جرب هذا الكود

Public Sub Ali_t()

Dim Sh As Worksheet

Dim S As Worksheet

Dim Ar, Rw, R, C, Rr, Cc

Set Sh = ورقة1

Set S = ورقة2

Rr = 14: Cc = 1

Ar = Array(2, 3, 4, 17, 20, 23, 26, 29, 32, 35, 38, 41, 42, 46, 49, 52, 55, 59, 62)

Rw = Cells(Rows.Count, 2).End(xlUp).Row

Application.ScreenUpdating = False

For C = LBound(Ar) To UBound(Ar)

For R = 14 To Rw

If Sh.Cells(R, 1) <> "" Then

Cl = Ar(C)

S.Cells(R, Cc) = Sh.Cells(R, Cl)

End If

Next

Cc = Cc + 1

Next

Application.ScreenUpdating = True

End Sub

[الـعيدروس]

السموحه منك اخي ابو حنين

لم ارى مشاركتك القيمة الا بعد الرد

[رشوان احمد]

الاستاذ ابو حنين

فى خطا فى ترحيل الاسم لمكان الفصل و3 عواميد اخر عواميد لا يصل بهم الترحيل

الاستاذ عباد

شكرا لك وشكرا للاستاذ ابو حنين

كود الاستاذ عباد يعمل كما طلبت جزاكم الله خير

تم تعديل ديسمبر 14, 2012 بواسطه رشوان احمد

[أبو حنــــين]

أشكرك أخي الحبيب أيو نصار

أخي أحمد بالفعل كان هناك خطأ حيث كنت قد نسيت أحد الأعمدة المعنية بالنسخ و هذا هو التصحيح للكود السابق

Sub AbouHanine()

Dim LR As Integer, X As Integer, RR

With ورقة2

.Range("A14:S200").ClearContents: .Range("A14:S200").Borders.LineStyle = xlNone

End With

LR = Cells(Rows.Count, "B").End(xlUp).Row

Application.ScreenUpdating = False

X = 14

For i = 14 To LR

With ورقة1

Set RR = Application.Union(.Range("b" & i), .Range("c" & i), .Range("d" & i), .Range("q" & i) _

, Range("t" & i), Range("w" & i), Range("z" & i), .Range("ac" & i), .Range("af" & i) _

, .Range("ai" & i), .Range("al" & i), .Range("ao" & i), .Range("ap" & i), .Range("at" & i) _

, .Range("aw" & i), .Range("az" & i), .Range("bc" & i), .Range("bg" & i), .Range("bj" & i))

	 RR.Copy

End With

With ورقة2

.Range("a" & X).PasteSpecial xlPasteValues

.Range("a" & X).Borders.LineStyle = xlContinuous: .Range("b" & X).Borders.LineStyle = xlContinuous

.Range("d" & X).Borders.LineStyle = xlContinuous: .Range("c" & X).Borders.LineStyle = xlContinuous

.Range("d" & X).Borders.LineStyle = xlContinuous: .Range("e" & X).Borders.LineStyle = xlContinuous

.Range("f" & X).Borders.LineStyle = xlContinuous: .Range("g" & X).Borders.LineStyle = xlContinuous

.Range("h" & X).Borders.LineStyle = xlContinuous: .Range("i" & X).Borders.LineStyle = xlContinuous

.Range("j" & X).Borders.LineStyle = xlContinuous: .Range("k" & X).Borders.LineStyle = xlContinuous

.Range("l" & X).Borders.LineStyle = xlContinuous: .Range("m" & X).Borders.LineStyle = xlContinuous

.Range("n" & X).Borders.LineStyle = xlContinuous: .Range("o" & X).Borders.LineStyle = xlContinuous

.Range("p" & X).Borders.LineStyle = xlContinuous: .Range("q" & X).Borders.LineStyle = xlContinuous

.Range("r" & X).Borders.LineStyle = xlContinuous: .Range("s" & X).Borders.LineStyle = xlContinuous

	 Application.CutCopyMode = False

	 X = X + 1

	 End With

	 Next i

Application.ScreenUpdating = True

MsgBox "ثم ترحيل البيانات بنجاح", vbInformation, "ترحيل"

ورقة2.Select

End Sub

ترحيل2.rar

[منياوى]

رائع والف الف شكر

[رشوان احمد]

الاستاذ ابو حنين

شكرا لك وجذاك الله الخير

لى سؤال لو سمحت ممكن الترحيل بهذه الطريقة الى الشهادات

اضافة ورقة3 بنفس الشكل كشهادة للطالب

تم تعديل ديسمبر 15, 2012 بواسطه رشوان احمد