Jump to content
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


Go to solution Solved by سليم حاصبيا,

Recommended Posts

السلام عليكم

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

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

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

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

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

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

Link to post
Share on other sites

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

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

  • Like 2
Link to post
Share on other sites
Posted (edited)

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

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

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

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

2146009379_.png.24064ed694a9e636400172598b2e2ecf.png

 

Edited by مصطفى محمود مصطفى
  • Like 1
Link to post
Share on other sites

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

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

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

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

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

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

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

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

Link to post
Share on other sites

أضف هذا العبارة في نهاية الكود  قبل  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

 

  • Like 1
Link to post
Share on other sites
Posted (edited)

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

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

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

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

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

تحياتي لكم

 

خطا التاريخ.png

خطا كود تعديل التاريخ.png

Edited by مصطفى محمود مصطفى
Link to post
Share on other sites
  • Solution

تصحيح بسيط

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

 

  • Like 1
Link to post
Share on other sites

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

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

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

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

تحياتي لكم

  • Like 1
Link to post
Share on other sites
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

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

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

  • Like 1
Link to post
Share on other sites

السلام عليكم

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

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

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

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

2105674516_.jpg.182d5a60206b68e0e1909d0e736c561d.jpg

Link to post
Share on other sites
4 دقائق مضت, مصطفى محمود مصطفى said:

السلام عليكم

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

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

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

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

2105674516_.jpg.182d5a60206b68e0e1909d0e736c561d.jpg

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

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

  • Like 1
Link to post
Share on other sites

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

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

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

 

If_condition.PNG

  • Like 2
Link to post
Share on other sites

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

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

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

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

 

  • Like 1
Link to post
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

Guest
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • Recently Browsing   0 members

    No registered users viewing this page.

×
×
  • Create New...