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



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






اضافة رد جديد اضافة موضوع جديد

الصفحة 2 من 2 < 1 2 > الأخيرة


28-07-2020 11:30 صباحاً
السلام عليكم ورحمة الله وبركاته
معي كود قمت بالتعديل عليه ولكن لم يضبط معي
ولا اعرف الخلل من اين؟؟؟؟
اريد ترحيل البيانات من صفحة الرصد الى صفحة الشيت

NjM4NTgx3attachخطأ.rar
هذا هو الكود
CODE
Sub ترحيل_من_الرصد()
    Rem الإعلان عن المتغيرات ومنها مصفوفة سيكون عدد الأعمدة فيها 4 وتعبر عن النتائج
    Dim a(1 To 10000, 1 To 15), ws As Worksheet, sh As Worksheet, lr As Long, r As Long, m As Long
    Rem إيقاف اهتزاز الشاشة لتسريع الكود
    Application.ScreenUpdating = False
        Rem تعيين ورقة العمل التي يتم ترحيل البيانات منها
        Set ws = ThisWorkbook.Worksheets("الرصد")
        Rem تعيين ورقة العمل التي يتم ترحيل البيانات إليها
        Set sh = ThisWorkbook.Worksheets("الشيت")
        Rem تحديد رقم آخر صف به بيانات بناءً على العمود الثالث في ورقة البيانات
        lr = ws.Cells(Rows.Count, "C").End(xlUp).Row
        Rem حلقة تكرارية من الصف الخامس لآخر صف به بيانات وبتخطي 4 صفوف
        For r = 5 To lr
            Rem استخدام المتغير كعداد ويزيد في كل مرة بمقدار واحد
            m = m + 4
            Rem وضع المسلسل في أول عمود في المصفوفة
            a(m, 1) = m
            Rem وضع رقم الجلوس في العمود الثاني في المصفوفة
            a(m, 2) = ws.Cells(r, 2).Value  'Seat Number
            Rem وضع اسم الطالب في العمود الثالث في المصفوفة
            a(m, 3) = ws.Cells(r, 3).Value  'Student Name
            Rem وضع درجة الطالب في العمود الرابع في المصفوفة
            a(m, 5) = ws.Cells(r, 5).Value  'Mark
            a(m, 6) = ws.Cells(r, 6).Value
                  Rem الانتقال للمجموعة التالية بعد تخطي 4 صفوف
        Next r
        Rem بدء التعامل مع الخلية في ورقة العمل التي سيتم ترحيل البيانات إليها
        With sh.Range("A5")
            Rem مسح النطاق بدايةً من الخلية وبامتداد 4 أعمدة مع استثناء أول 9 صفوف
            .Resize(Rows.Count - 4, 29).ClearContents
            Rem وضع نتائج المصفوفة في ورقة العمل الهدف
            .Resize(UBound(a, 1), UBound(a, 2)).Value = a
        End With
    Rem استرجاع خاصية اهتزاز الشاشة في نهاية الكود
    Application.ScreenUpdating = True
End Sub
 
 
  خطأ.rar   تحميل rar مرات التحميل :(1)
الحجم :(119.314) KB





look/images/icons/i1.gif خطآ بالكود-ترحيل
  28-07-2020 03:30 مساءً   [1]
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس :
تاريخ الميلاد : 1-5-1989
الدعوات : 1
قوة السمعة : 6611
الاعجاب : 2
عندما تتوقفين عن استعمال الخلايا المدمجة داخل الجدول
بحيث تفصليها عن باقي البيانات بصف فارغ او عامود فارغ

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

أثارت هذه المشاركة إعجاب: نصر الإيمان،



look/images/icons/i1.gif خطآ بالكود-ترحيل
  28-07-2020 03:36 مساءً   [2]
معلومات الكاتب ▼
تاريخ الإنضمام : 15-02-2018
رقم العضوية : 4397
المشاركات : 449
الجنس :
تاريخ الميلاد : 29-12-1985
قوة السمعة : 1085
الاعجاب : 0
أقصد استاذ سليم....
هذا الكود تم استخدامه بالمصفوفات...ورحل أثناء وجود خلايا مدمجه...من صفحة الداتا...إلى صفحة الرصد....
......
أما الان اريد معرفة الخلل باالكود الموجود عند
ترحيل البيانات من صفحة الرصد...إلى صفحة الشيت...




look/images/icons/i1.gif خطآ بالكود-ترحيل
  28-07-2020 04:23 مساءً   [3]
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس :
تاريخ الميلاد : 1-5-1989
الدعوات : 1
قوة السمعة : 6611
الاعجاب : 2
لا أحب ان أعمل على المصفوفات في عمليات الترحيل
يمكن اذا اردت هذا الماكرو
بعد ضبط وضع الجدول (بدون خلايا مدمجة)
اضافة صف فارغ رقم 5 (مخفي) وعامود فارغ "C"(يمكن اخفاءه)
لكن تركته حتى ترينه
CODE

  Sub My_tarhil()
   Dim Rsd As Worksheet
   Dim Sh As Worksheet
   Dim i%, m%
   Set Rsd = Sheets("الرصد")
   Set Sh = Sheets("الشيت")
  i = 7: m = 6
  Do Until Rsd.Cells(i, 4) = vbNullString
      Sh.Cells(m, 5).Resize(, 20).Value = _
      Rsd.Cells(i, 4).Resize(, 20).Value
      
      Sh.Cells(m, "y").Resize(, 5).Value = _
      Rsd.Cells(i, "y").Resize(, 5).Value
      
      Sh.Cells(m, "A").Resize(, 3).Value = _
      Rsd.Cells(i, "A").Resize(, 3).Value
  m = m + 4
  i = i + 1
  Loop
  End Sub


الملف مرفق
 
 
  Iman_error.xlsm   تحميل xlsm مرات التحميل :(3)
الحجم :(284.013) KB


أثارت هذه المشاركة إعجاب: ابو طيبه، نصر الإيمان، YasserKhalil،



look/images/icons/i1.gif خطآ بالكود-ترحيل
  28-07-2020 11:14 مساءً   [4]
معلومات الكاتب ▼
تاريخ الإنضمام : 15-02-2018
رقم العضوية : 4397
المشاركات : 449
الجنس :
تاريخ الميلاد : 29-12-1985
قوة السمعة : 1085
الاعجاب : 0
تسلم استاذ سليم.... هل من تعديل استاذنا في الكود اللي رفعته قبل ذلك...
باستخدام المصفوفات.. بحيث يبقى تمام... ومش لازم وجود خلايا مدمجه عادي؟؟؟؟
وهل حضرتك استخدام المصفوفات في الترحيل خطآ ..... ام ماذا؟؟؟؟




look/images/icons/i1.gif خطآ بالكود-ترحيل
  28-07-2020 11:29 مساءً   [5]
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس :
تاريخ الميلاد : 1-5-1989
الدعوات : 1
قوة السمعة : 6611
الاعجاب : 2
وهل حضرتك استخدام المصفوفات في الترحيل خطآ ..... ام ماذا؟؟؟؟[/quote]
استخدام المصفوفات في الترحيل ليس خطأ
لكن تصوري اننا نبحث عن مجموعة بيانات لنضعها في مصفوفة
و عند اكتمال المصفوفة نقوم بوضعها في المكان المناسب في الشيت المناسب
فلماذا لا نقوم بوضع ما نفتش عنه رأساً في المكان المناسب
دون المرور بالمصفوفة

أثارت هذه المشاركة إعجاب: نصر الإيمان،



look/images/icons/i1.gif خطآ بالكود-ترحيل
  29-07-2020 02:54 صباحاً   [6]
معلومات الكاتب ▼
تاريخ الإنضمام : 15-02-2018
رقم العضوية : 4397
المشاركات : 449
الجنس :
تاريخ الميلاد : 29-12-1985
قوة السمعة : 1085
الاعجاب : 0
لكن المصفوفه اسرع بكثير مع كثرة البيانات.....
هل من تعديل على الكود بالمصفوفه جزاك الله خيرا....
لان في فراغات الكود بيتجاهلها




look/images/icons/i1.gif خطآ بالكود-ترحيل
  29-07-2020 03:28 صباحاً   [7]
معلومات الكاتب ▼
تاريخ الإنضمام : 15-02-2018
رقم العضوية : 4397
المشاركات : 449
الجنس :
تاريخ الميلاد : 29-12-1985
قوة السمعة : 1085
الاعجاب : 0
هل ممكن حضرتك ترحل عمود واحد فقط كمثال توضيحي..وليكن ماده ٣....باستخدام المصفوفه كمثال...ونا أن شاء الله اكمل الباقي..
والله المستعان.




look/images/icons/i1.gif خطآ بالكود-ترحيل
  29-07-2020 07:45 صباحاً   [8]
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس :
تاريخ الميلاد : 1-5-1989
الدعوات : 1
قوة السمعة : 6611
الاعجاب : 2
ربما تريدين هذا الكود( التنفيذ في صفحة new_sheet)
مصفوفات مع خلايا مدمجة
CODE

Option Explicit

 Sub By_array()
   Dim Rsd As Worksheet
   Dim NW As Worksheet
   Dim Rg_to_copy As Range
   Dim A
   Dim i%, m%, x%, y%, t%
   
   Set Rsd = Sheets("الرصد")
   Set NW = Sheets("New_sheet")
   
   Application.ScreenUpdating = False
   If NW.Range("A6").CurrentRegion.Rows.Count > 1 Then
    NW.Range("A6").CurrentRegion.Offset(1). _
    Resize(NW.Range("A6").CurrentRegion.Rows.Count - 1).Clear
   End If
  Set Rg_to_copy = Rsd.Range("A6").CurrentRegion
  If Rg_to_copy.Rows.Count = 1 Then GoTo Au_Revoir
  Set Rg_to_copy = Rg_to_copy.Offset(1).Resize(Rg_to_copy.Rows.Count - 1)
A = Rg_to_copy
m = 7
For x = 1 To UBound(A)
      For y = 1 To UBound(A, 2)
       NW.Cells(m, 1).Offset(, y - 1) = A(x, y)
      Next y
      
      For t = 1 To 3
       NW.Cells(m, t).Resize(4).Merge
      Next t
       
       NW.Cells(m, 4).Resize(, UBound(A, 2) - 3). _
       Interior.ColorIndex = 35
 m = m + 4
Next x
If NW.Range("A6").CurrentRegion.Rows.Count > 1 Then
  With NW.Range("A6").CurrentRegion.Offset(1). _
      Resize(NW.Range("A6").CurrentRegion.Rows.Count - 1)
    .VerticalAlignment = 2: .HorizontalAlignment = 3
    .Borders.LineStyle = 1
    .Font.Bold = True: .Font.Size = 14
  End With
End If
Au_Revoir:
Application.ScreenUpdating = True
  End Sub


 
 
  my_error.xlsm   تحميل xlsm مرات التحميل :(4)
الحجم :(330.32) KB


أثارت هذه المشاركة إعجاب: نصر الإيمان،



look/images/icons/i1.gif خطآ بالكود-ترحيل
  29-07-2020 01:11 مساءً   [9]
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس :
تاريخ الميلاد : 1-5-1989
الدعوات : 1
قوة السمعة : 6611
الاعجاب : 2
ربما يكون هذا الملف اكثر جمالاً من حيث التنسيق
 
 
  my_error1.xlsm   تحميل xlsm مرات التحميل :(3)
الحجم :(332.852) KB


أثارت هذه المشاركة إعجاب: نصر الإيمان،



look/images/icons/i1.gif خطآ بالكود-ترحيل
  30-07-2020 01:30 مساءً   [10]
معلومات الكاتب ▼
تاريخ الإنضمام : 15-02-2018
رقم العضوية : 4397
المشاركات : 449
الجنس :
تاريخ الميلاد : 29-12-1985
قوة السمعة : 1085
الاعجاب : 0
جزاك الله خيرا استاذ سليم...
ممكن من فضلك عمود واحد فقط يتم ترحيله كمثال...لان الكود عند دراسته صعب اعدل عليه..
استاذن حضرتك عمود واحد فقط كمثال وليكن العمود(N)
عشان اقيس عليه

أثارت هذه المشاركة إعجاب: YasserKhalil،



look/images/icons/i1.gif خطآ بالكود-ترحيل
  30-07-2020 06:46 مساءً   [11]
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس :
تاريخ الميلاد : 1-5-1989
الدعوات : 1
قوة السمعة : 6611
الاعجاب : 2
مثال عما تريدينه (العامود D)
CODE

Option Explicit
 Sub Only_One()
   Dim Rsd As Worksheet
   Dim NW As Worksheet
   Dim Rg_to_copy As Range
   Dim A, shp As Shape
   Dim i%, m%, x%, y%, t%
   Dim max_ro%, Ld%
   Set Rsd = Sheets("الرصد")
   Set NW = Sheets("New_sheet")
   max_ro = Rsd.Cells(Rows.Count, "D").End(3).Row
   Application.ScreenUpdating = False
    NW.Range("A7").Resize(max_ro * 10, 30).Clear
   For Each shp In NW.Shapes
     If shp.Name Like "Red*" Then
     shp.Delete
  End If
   Next

A = Application.Transpose(Rsd.Range("D7:D" & max_ro))

m = 7
For x = 1 To UBound(A)
 NW.Cells(m, "D") = A(x)
 m = m + 4
 Next

If NW.Range("A6").CurrentRegion.Rows.Count > 1 Then
 Ld = NW.Cells(Rows.Count, "d").End(3).Row
  With Range("D7:d" & Ld).SpecialCells(2)
    .VerticalAlignment = 2: .HorizontalAlignment = 3
    .Borders.LineStyle = 1
    .Font.Bold = True: .Font.Size = 14
    .Select
My_RedBox
  End With
End If
NW.Range("D7").Select
Au_Revoir:
Application.ScreenUpdating = True
  End Sub
  '+++++++++++++++++++++++++++++
Sub My_RedBox()

Dim redBox As Shape
Dim Act_rg As Range
Dim p%
Dim NW As Worksheet
Set NW = Sheets("New_sheet")
 For Each Act_rg In Selection.Cells

   Set redBox = NW.Shapes.AddShape(msoShapeRectangle, _
        Act_rg.Left, Act_rg.Top, _
        Act_rg.Width, Act_rg.Height)
     With redBox
       .Line.ForeColor.RGB = RGB(255, 0, 0)
       .Line.Weight = 3
       .Fill.Visible = msoFalse
       .Name = "RedBox_" & p + 1
     End With
     p = p + 1
 Next

End Sub
'+++++++++++++++++++++++
Sub de_Red()
Dim shp As Shape
For Each shp In Sheets("New_sheet").Shapes
     If shp.Name Like "Red*" Then
     shp.Delete
     End If
  Next
End Sub

 
 
  Only_col_D.xlsm   تحميل xlsm مرات التحميل :(1)
الحجم :(338.83) KB


أثارت هذه المشاركة إعجاب: نصر الإيمان،



look/images/icons/i1.gif خطآ بالكود-ترحيل
  30-07-2020 10:04 مساءً   [12]
معلومات الكاتب ▼
تاريخ الإنضمام : 15-02-2018
رقم العضوية : 4397
المشاركات : 449
الجنس :
تاريخ الميلاد : 29-12-1985
قوة السمعة : 1085
الاعجاب : 0
جزاك الله خيرا استاذ سليم...سلمت يداك
...لكن هل من حل في عدم مسح الخلايا الاخرى التي بالعمود(D(
بمعنى : لو تم وجود بيانات بين المربعات الحمراء تفضل كما هي ..والترحيل يكون للمربعات الحمراء فقط
MjUyMjU5MQ7575111
 
 



تم تحرير المشاركة بواسطة :نصر الإيمان بتاريخ:30-07-2020 10:06 مساءً





اضافة رد جديد اضافة موضوع جديد
الصفحة 2 من 2 < 1 2 > الأخيرة




المواضيع المتشابهه
عنوان الموضوع الكاتب الردود الزوار آخر رد
خطآ بظهور التقدير في المعادله نصر الإيمان
3 814 نصر الإيمان

الكلمات الدلالية
بالكود-ترحيل ،








اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 05:15 PM.