ترحيل بيانات

[الشيباني1]

اخواني الاعزاء تحية طيبه ارجو المساعده فيما جاء بالمرفق مع الامتنان

____________.rar

[ابو اسامة العينبوسي]

السلام عليكم

اليك حل سريع (انا الان في العمل)

Sub trheelomar()
Dim y As Integer
Dim xx As Variant
Range("rr").ClearContents
 xx = Array(" ", "ثامر ناصر", "باهر احمد", "عبد الوهاب امجد", "يوسف حسين", "كامل محمد", "محمد احمد", "رافت سليم", "حامد ياسر", "طالب مصطفى")
For i = 4 To 42
  For x = 1 To 10
   If Cells(i, 3) = xx(x - 1) Then
   Select Case Cells(i, 3)
   Case Is = xx(0)
   y = 6
   Case Is = xx(1)
   y = 8
   Case Is = xx(2)
   y = 11
   Case Is = xx(3)
   y = 14
   Case Is = xx(4)
   y = 17
   Case Is = xx(5)
   y = 20
   Case Is = xx(6)
   y = 23
   Case Is = xx(7)
   y = 26
   Case Is = xx(8)
   y = 29
   Case Is = xx(9)
   y = 32
   Case Is = xx(10)
   y = 35
   End Select
   YY = Cells(Rows.Count, y).End(xlUp).Row + 1
   Cells(YY, y) = Cells(i, 2)
   Cells(YY, y + 1) = Cells(i, 5)
   Cells(YY, y + 2) = Cells(i, 4)
  End If
  Next
Next
End Sub

____________2.rar

تم تعديل أبريل 15, 2009 بواسطه ابو اسامة العينبوسي

[عادل حنفي]

السلام عليكم

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

اكوادك بالفعل جميله و من اعجابي بالكود حاولت تفهمه

و المحاوله بالتغلب علي عدم ترحيل الاسم الباقي

و عملت محاولة اعلم انها قد تكون ليست هي الحل الامثل

و لكنها حلت المشكله

فتقبل اعتذاري

خالص تحياتي و تقديري

_______________.rar

[ابو اسامة العينبوسي]

السلام عليكم

اخى عادل شكرا لك على المرور

الكود اعلاه قمت بتعديله وهو يعمل

و الان ساطلع على كودك

[الشيباني1]

اخواني الاعزاء تحية طيبه بصراحة ابداع ما بعده ابداع اشكركم على تعاونكم سائلا العلي القدير ان يديم عليكم علمكم وذكاءكم وخبرتكم ، متسائلا عن امكانية ايضاح كيفية اجراء تعديل على الكود الرائع لنقله الى ورقة العمل التي اعمل عليها( فيما يتعلق بالاسطر والاعمده واختلاف امكنتها ) مع الامتنان

[الشيباني1]

اخواني الاعزاء في الوقت الذي اعتذر فيه عن اقتطاع جزء من وقتكم في هذا الموضوع الذي وجدت في حلكم الرائع مبتغاي ، ارفق طيا نموذجا من ورقة العمل التي اعمل عليها راجيا (ان امكن ) اجراء ما يلزم على الكود ليتناسب مع المرفق مع الامتنان

Example.zip

[ابو اسامة العينبوسي]

السلام عليكم

____________3.rar

[الشيباني1]

أستاذي العزيز اللسان عاجز عن شكركم على هذا الابداع ، تعديل بسيط انشاء الله عليكم صعب علي ، في المثال الذي ارسلته حددت مدى الجدول (v9 - y6000) كي اقوم باستنساخ الكود الى ورقة العمل بدون تغيير (لقلة خبرتي في الاكواد) وفي حلكم الرائع استبعد هذا المدى ،ارجو المساعده بتفصيل الحل على المدى الذي ثبته مع جزيل الشكر والامتنان

[الشيباني1]

استاذنا الكريم ملاحظة اخرى انتبهت اليها متأخرا وهي عند اضافة بيانات جديده الى الجدول وترحيلها تتكرر البيانات السابقه في جداول الوكلاء ارجو ملاحظة ذلك مع الشكر

[ابو اسامة العينبوسي]

السلام عليكم

Example3.rar

[الشيباني1]

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

[ابو اسامة العينبوسي]

السلام عليكم

2003

Example4.rar

[الشيباني1]

أستاذنا العزيز رائع بكل معنى الكلمه اشكرك وادامك الرحمن لنا مرجعا

[ابو اسامة العينبوسي]

السلام عليكم

انت تجعل السطر 6 من الصفحة الخلاصه فارغ

هنا الكود عدل ليتناسب مع مبتغاك

Sub trheelomar()
Dim y As Integer
Dim xx As Variant
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheets(2).Select
Range(Cells(6, 2), Cells(50, 29)).ClearContents
Sheets(1).Select

 xx = Array("", "ËÇãÑ äÇÕÑ", "ÈÇåÑ ÇÍãÏ", "ÚÈÏ ÇáæåÇÈ ÇãÌÏ", "íæÓÝ ÍÓíä", "ßÇãá ãÍãÏ", "ãÍãÏ ÇÍãÏ", "ÑÇÝÊ Óáíã", "ÍÇãÏ íÇÓÑ", "ØÇáÈ ãÕØÝì")
For i = 11 To 48
   For x = 1 To 10
   If Cells(i, 23) = xx(x - 1) Then
   Select Case Cells(i, 23)
   Case Is = xx(1)
   y = 2
   Case Is = xx(2)
   y = 5
   Case Is = xx(3)
   y = 8
   Case Is = xx(4)
   y = 11
   Case Is = xx(5)
   y = 14
   Case Is = xx(6)
   y = 17
   Case Is = xx(7)
   y = 20
   Case Is = xx(8)
   y = 23
   Case Is = xx(9)
   y = 26
   End Select
   yy = Sheets(2).Cells(Rows.Count, y).End(xlUp).Row + 1
   If yy = 6 Then
   yy = Sheets(2).Cells(Rows.Count, y).End(xlUp).Row + 2
   End If
   Sheets(2).Cells(yy, y) = Cells(i, 22)
   Sheets(2).Cells(yy, y + 1) = Cells(i, 25)
   Sheets(2).Cells(yy, y + 2) = Cells(i, 24)
  End If
  Next
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

تم تعديل أبريل 18, 2009 بواسطه ابو اسامة العينبوسي