ترحيل حسب الشرط

[skyblue]

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

اعضاء منتدانت الرائع مرفق ملف ارجوا التكرم بالتعديل عليه

تحياتي

[علي السحيب]

الكود التالي ينفذ ما تريد:

Sub Sorting()

A = Application.WorksheetFunction.Match(1, [A3:A7], 0) + 2
B = Application.WorksheetFunction.Match(6, [A3:A7], 0) + 2
C = Application.WorksheetFunction.Match(4, [A3:A7], 0) + 2
D = Application.WorksheetFunction.Match(2, [A3:A7], 0) + 2
E = Application.WorksheetFunction.Match(3, [A3:A7], 0) + 2

[A13:J16].ClearContents

If [A9] = "" Then Exit Sub

If [A9] = 8 Then

For F = 1 To 10
Cells(13, F) = Cells(A, F)
Cells(14, F) = Cells(B, F)
Cells(15, F) = Cells(C, F)
Next

Else:
For F = 1 To 10
Cells(13, F) = Cells(A, F)
Cells(14, F) = Cells(D, F)
Cells(15, F) = Cells(E, F)
Cells(16, F) = Cells(C, F)
Next

End If

End Sub

_______________.rar

[skyblue]

استاذي علي السحيب حفظك الله

كود مافيه اروع منه بس ارغب ان تتكرم بجعله يعمل اليا بدون زر عن طريق Private Sub

تحياتي لك

[علي السحيب]

بعد نقل الكود إلى الصفحة المعنية تحت المتغير Change .. فقط نقوم بإضافة السطر التالي في بداية الكود .. وهو يعمل على تحديد عنوان الخلية التي سينطلق منها الكود عند حدوث أي تغيير عليها.

If Target.Address = "$A$9" Then

شاهد المرفق،

_______________.rar

[skyblue]

استاذي :علي السحيب

لو وضعنا البيانات الاساسية ( A2:j7) في sheet2 والنتيجة كماهي حتكون في sheet1 كيف حيكون الكود .

لان جميع مواضيعي اللي انت يحفظك الله رديت عليها اخيرا وهي : هذا الموضوع - وموضوع الكود يعمل بدون زر - واخيرا كان موضوع البحث , حيث انها كانت تمثل عقبة امامي وكنت اتمنى ان اجد حل لتلك المواضيع الى ان اراد الله وسخر لي اخ كريم حبيب محب للخير اخي واستاذنا :علي بن حسين السحيب وحل مواضيعي بشكل احترافي حلا كافيا وافيا .

لك مني الف تحية والمعذرة على كثرة الاسئلة .وكل عام وانت بخير مقدما

sky22033@gmail.com

[علي السحيب]

فقط نقوم بإضافة إسم الصفحة التي يوجد بها البيانات (Sheet2) قبل أرقام الخلايا التي سوف يتم جلب البيانات منها .. فيصبح الكود كالتالي:

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Address = "$A$9" Then

A = Application.WorksheetFunction.Match(1, Sheet2.[A3:A7], 0) + 2
B = Application.WorksheetFunction.Match(6, Sheet2.[A3:A7], 0) + 2
C = Application.WorksheetFunction.Match(4, Sheet2.[A3:A7], 0) + 2
D = Application.WorksheetFunction.Match(2, Sheet2.[A3:A7], 0) + 2
E = Application.WorksheetFunction.Match(3, Sheet2.[A3:A7], 0) + 2

[A13:J16].ClearContents

If [A9] = "" Then Exit Sub

If [A9] = 8 Then

For F = 1 To 10
Cells(13, F) = Sheet2.Cells(A, F)
Cells(14, F) = Sheet2.Cells(B, F)
Cells(15, F) = Sheet2.Cells(C, F)
Next

Else:
For F = 1 To 10
Cells(13, F) = Sheet2.Cells(A, F)
Cells(14, F) = Sheet2.Cells(D, F)
Cells(15, F) = Sheet2.Cells(E, F)
Cells(16, F) = Sheet2.Cells(C, F)
Next

End If
End If
End Sub

شاهد المرفق،

وشاهد أيضاً التعديل الذي طلبت على هذا الموضوع:

http://www.officena.net/ib/index.php?showtopic=13905

_______________.rar

تم تعديل أكتوبر 18, 2006 بواسطه علي السحيب