ارجو المساعدة فى كود الترحيل هذا

[محمد نوح]

السلام عليكم ورحمة الله وبركاته

الاخوه الكرام هذا الكود للاخ الفاضل ابو نصار تم تعديلة بما يتناسب مع عملى ولكن بعد التعديل يوجد مشكلة فى الترحيل حيث يتم اختيار الصفحة المراد الترحيل اليها من عامود البيان وكتابه البيانات المراد ترحيلها فى الصفحة M1 فى الاعمدة باللون الاصفر والبيانات المراد ترحيلها للصفحة M2 فى الاعمدة باللون الرمادى .

ارجو المساعدة

وجزاكم الله كل الخير...M1.rar

[الـعيدروس]

السلام عليكم

جرب هذا التعديل

Public Sub Ali_T()

Dim Sh As Worksheet

Dim R As Range

With Application

    .ScreenUpdating = False

    .Calculation = xlCalculationManual

For Each Sh In ThisWorkbook.Worksheets

If Not Sh.Name = "الكشف الرئيسي" Then

For Each R In Range("A4:A500")

If Not IsEmpty(R) And R.Text = Sh.Name Then

Select Case R.Text

	 Case Is = "M2"

	   R.Offset(0, 23).Resize(1, 7).Copy

	   Sh.Select

	   L_a = Sh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

	   If L_a - 1 = 1 Then A = 7 Else A = L_a

	   Sh.Range("A" & A).PasteSpecial xlPasteValues

	   Feuil1.Select

	   L_a = L_a + 1: A = A + 1

	 Case Is = "M1"

	   R.Offset(0, 1).Resize(1, 22).Copy

	   Sh.Select

	   L_a = Sh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

	   If L_a - 1 = 1 Then A = 7 Else A = L_a

	   Sh.Range("A" & A).PasteSpecial xlPasteValues

	   Feuil1.Select

	   L_a = L_a + 1: A = A + 1

End Select

End If

Next

End If

Next

    .ScreenUpdating = True

    .Calculation = xlCalculationAutomatic

    .CutCopyMode = False

End With

Set R = Nothing

End Sub

تم تعديل ديسمبر 31, 2012 بواسطه عباد

[محمد نوح]

اخى الكريم ابو نصار

جزاك الله خيرا على الرد السريع وجعله الله سبحانه وتعالي فى ميزان حسناتك ان شاء الله

سوف اجرب هذا الكود واتمنى من الله ان يفى بالغرض

مع خالص تمنياتى بالتوفيق