استدعاء بيانات من اعمدة متفرقة الى الورقة الهدف

[مصطفى محمود مصطفى]

السلام عليكم

الاساتذة الكرام وفقكم الله

وجدت في المنتدى كودين للترحيل و الاستدعاء  ومن اعمدة متفرقة  وحاولت تنفيذه على ملفي فتعطي النتيجة خطا علما غيرت المعطيات كما في الشرح

ارجو التفضل باجراء تعديل على كود الاستدعاء وتجنب الخطا الصادر اثناء تنفيذ الكود

واذا كان هناك كود جديد يفي بالغرض فجزاكم الله خيرا

لكم وافر احترامي

استدعاء اعمدة متفرقة الى الورقة .xlsm

[سليم حاصبيا]

هذا الماكرو يقوم بما تريد

Option Explicit
Option Base 1
 Sub My_code()
    Dim m%, k%, lr%, i%
    Dim Main As Worksheet, sh As Worksheet
    Dim myArray, arr(11), targt$
    
    Set Main = Sheets("Allstudents")
    Set sh = Sheets("from.school")
    sh.Range("B7:M1000").Clear
    
    targt = "from*"
    lr = Main.Cells(Rows.Count, "D").End(xlUp).Row
    m = 7
    For i = 3 To 13
     arr(i - 2) = i
    Next
    
    myArray = Array(38, 4, 5, 27, 13, 16, 18, 19, 20, 21, 22)
For i = 5 To lr
      If Main.Cells(i, "AD") Like "*" & targt Then
        For k = 1 To 11
         sh.Cells(m, arr(k)) = Main.Cells(i, myArray(k))
       Next
       m = m + 1
    End If
Next

With sh.Range("B7").Resize(m - 7, 13)
    .Borders.LineStyle = 1
    .HorizontalAlignment = 1
    .InsertIndent 1
        With .Font
          .Bold = True
          .Size = 14
        End With
End With
End Sub

الملف مرفق

My_data .xlsm

[مصطفى محمود مصطفى]

شكرا لكم على سرعة الاجابة وفقكم الله

ودائما مبدع استاذ سليم

عند تنفيذ الكود ظهر خطا لا في السطر الاصفر

لكم وافر احترامي وتقديري

 

تم تعديل مارس 18, 2020 بواسطه مصطفى محمود مصطفى

[سليم حاصبيا]

الخطأ مطبعي في الــ Dim

يجب كتابة   $targt  و ليس &targt

Dim myArray, arr(11), targt$

 

[مصطفى محمود مصطفى]

نسال الله سبحانه وتعالى ان يوفقكم ويحفظكم استاذ سليم

الكود يعمل  الان بعد التعديل بشكل ممتاز ورائع

تقبلوا وافر احترامي وتقديري

السلام عليكم استاذ سليم

عند ترحيل التاريخ يظهر على شكل رقم ونسقت الخلايا التي يرحل لها التاريخ نسقتها تاريخ

لكن عند تنفيذ الكود كذلك ترجع ارقام

هل ممكن حل للمشكلة

جزاكم الله خيرا

[سليم حاصبيا]

أضف هذا العبارة في نهاية الكود  قبل  End With  الأخيرة

.Value = .Value

لتصبح نهاية الكود هكذا

With sh.Range("B7").Resize(m - 7, 13)
    .Borders.LineStyle = 1
    .HorizontalAlignment = 1
    .InsertIndent 1
        With .Font
          .Bold = True
          .Size = 14
        End With
     .Value = .Value
End With

End Sub

 

[مصطفى محمود مصطفى]

الاخ سليم جزاكم الله خيرا

الخطا لازال والتاريخ لم ينسق بعد اضافة التعديل

علما وضعت التعديل قبل الاخيره

With sh.Range("b7").Resize(m - 7, 12)
    .Borders.LineStyle = 1
    .HorizontalAlignment = 1
    .InsertIndent 1
        With .Font
          .Bold = True
          .Size = 14
           
        End With
        .Value = .Value
End With
End Sub

ولم يتم تعديل التاريخ لكن رسالة الخطأ اختفت

تحياتي لكم

 

تم تعديل مارس 18, 2020 بواسطه مصطفى محمود مصطفى

[سليم حاصبيا]

تصحيح بسيط

With sh.Range("B7").Resize(m - 7, 13)
    .Borders.LineStyle = 1
    .HorizontalAlignment = 1
    .InsertIndent 1
        With .Font
          .Bold = True
          .Size = 14
        End With
        '++++++++++++++++++++++++++++++++++++++++++++++++++++++
        '   الرقم 10 هنا يرمز الى رقم العامود في الجدول حيث يوجد التاريخ
        'أقصد العمود K
   .Columns(10).NumberFormat = "yyyy/m/d"
        '+++++++++++++++++++++++++++++++++++++++++++++++++++++++
End With
End Sub

 

[مصطفى محمود مصطفى]

بارك الله في صحتكم ورزقكم اخي سليم

جعله الله في ميزان حسناتكم وزادكم من فضله

الكود بعد التعديل  يعمل بشكل ممتاز واضفت الاعمدة الاخرى تحت بعض وعمل بشكل صحيح

والخطا في كتابة رقم العمود المطلوب من قبلي

تحياتي لكم

[قصي]

Option Explicit
Option Base 1

 Sub My_code()
    Dim m%, k%, lr%, i%
    Dim Main As Worksheet, sh As Worksheet
    Dim myArray, arr(11), targt$
    
    Set Main = Sheets("Allstudents")
    Set sh = Sheets("from.school")
    sh.Range("B7:M1000").Clear
    
    targt = "from*"
    lr = Main.Cells(Rows.Count, "D").End(xlUp).Row
    m = 7
    For i = 3 To 13
     arr(i - 2) = i
    Next
    
    myArray = Array(38, 4, 5, 27, 13, 16, 18, 19, 20, 21, 22)
For i = 5 To lr
      If Main.Cells(i, "AD") Like "*" & targt Then
        For k = 1 To 11
         sh.Cells(m, arr(k)) = Main.Cells(i, myArray(k))
       Next
       m = m + 1
    End If
Next

With sh.Range("B7").Resize(m - 7, 13)
    .Borders.LineStyle = 1
    .HorizontalAlignment = 1
    .InsertIndent 1
        With .Font
          .Bold = True
          .Size = 14
        End With
        '++++++++++++++++++++++++++++++++++++++++++++++++++++++
        '   الرقم 10 هنا يرمز الى رقم العامود في الجدول حيث يوجد التاريخ
        'أقصد العمود K
   .Columns(10).NumberFormat = "yyyy/m/d"
        '+++++++++++++++++++++++++++++++++++++++++++++++++++++++
End With
End Sub

الكود بعد كل الاضافات التي تمت بارك الله في الاستاذ سليم

وبارك الله في كل من يساعد على نشر العلم وليس اغلاقه

[قصي]

وهذا هو الملف بعد اضافه الكود له

استدعاء بيانات.rar

[مصطفى محمود مصطفى]

السلام عليكم

استاذ سليم حاصبيا تحياتي لكم

ارجو تعديل او اضافة للكود حيث اذا لم يجد بيانات يقوم باستدعائها حسب الشرط المفترض  يعطي رسالة خطا

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

لكم وافر احترامي

[سليم حاصبيا]

4 دقائق مضت, مصطفى محمود مصطفى said:

السلام عليكم

استاذ سليم حاصبيا تحياتي لكم

ارجو تعديل او اضافة للكود حيث اذا لم يجد بيانات يقوم باستدعائها حسب الشرط المفترض  يعطي رسالة خطا

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

لكم وافر احترامي

الملف قد مسحته من جهازي 

ارفع الملف من جديد للمعاينة

[مصطفى محمود مصطفى]

الله يبارك لكم في صحتكم اخي سليم 

لكم تحياتياستدعاء بيانات.xlsm

[سليم حاصبيا]

اضف هذا السطر الوحيد(بين علاملات الـــ +) في المكان المناسب

لم استطع رفع الكود من جديد لضعف النت

If m=7 then MsgBox "No Data to transfer": Exit Sub

 

[مصطفى محمود مصطفى]

الاستاذ سليم حاصبيا دعواتي لكم بدوام الصحة والعافية

انتهت المشكلة واصبح الكود يتجاوز الخطا المذكور

جعله الله سبحانه وتعالى في ميزان حسناتكم

لكم وافر الاحترام والتقدير