أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
ashraf_hertlion hassona229-- لا تميز خلال هذه الفترة YasserKhalil مطلوب تعديل الكود للطباعة اكسيل اسئله واجابات


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





ممكن توضيح اين الخطأ فى الكود المكون من تجميع كود للعلامة استاذ سليم والاستاذ ياسر

السلام عليكم اساتذة المنتدى احتاج توضيح حاولت ان اجمع بين كودين للاخوة الاساتذة اخى فى الله الكريم الاستاذ سليم واخى فى ..


موضوع مغلق

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


26-08-2020 08:50 مساء
omhamzh
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 27-05-2020
رقم العضوية : 19308
المشاركات : 137
الجنس : أنثى
يتابعهم : 1
يتابعونه : 0
قوة السمعة : 225
 offline 

السلام عليكم اساتذة المنتدى
احتاج توضيح
حاولت ان اجمع بين كودين للاخوة الاساتذة اخى فى الله الكريم الاستاذ سليم واخى فى الله الكريم استاذ ياسر
جمعت الكودين فى كود
وولكن الكود توقف فى جزئية احتاج لمعرفة السبب وطريقة علاج المشكلة مشكورين
Sub test()
    Dim x, ws As Worksheet, Sh As Worksheet, sName As String, R As Long, m As Long, n As Long, rng As Range
        Dim TR As Worksheet
    Dim Find_Range
    Dim Frst As Range, Third As Range
    Dim Sixth As Range
    Dim My_rg As Range
    Dim Ro1%, Ro%, col%, Last_Ro%
    Dim nEW_RO%, nEW_COL%
    Dim Answer As Byte
    Dim arr()

    Set TR = Sheets("transfer")
    Ro = TR.Cells(Rows.Count, 2).End(3).Row
    Set Frst = TR.Range("A2")
    Set Third = TR.Range("C2")
    Set Sixth = TR.Range("F2")
    Set My_rg = TR.Range("B3:E" & Ro)
      Dim XX%, cont%, Ro_E%
    Ro_E = TR.Cells(Rows.Count, "E").End(3).Row
  If Ro_E < 3 Then Ro_E = 3
 For XX = 3 To Ro_E
 cont = Application.CountA(TR.Cells(XX, 2).Resize(, 3))
 If cont < 2 Then
MsgBox " name in:" & XX
 Exit Sub
 End If
Next

If Frst = "" Then MsgBox "Date ": Exit Sub
If Third = "" Then _
 MsgBox "namber ": Exit Sub
 For Ro1 = 1 To My_rg.Columns(1).Cells.Count
  Set Sh = Sheets(My_rg.Cells(Ro1, 4) & "")
  If My_rg.Cells(Ro1, 3) = vbNullString Then
      MsgBox "ألخلية (" & My_rg.Cells(Ro1, 3).Address(0, 0) & ")" & _
      " في الورقة " & """" & TR.Name & """" & " فارغة" & Chr(10) & _
      "سأتجاوز هذا الأمر", vbMsgBoxRtlReading
      GoTo Next_Ro1
  End If
Next
For Ro1 = 1 To My_rg.Columns(1).Cells.Count
If My_rg.Cells(Ro1, 4) = vbNullString Then
 MsgBox "sheet name"
 Exit Sub
End If
Next
 If Sixth = "" Then _
 MsgBox "makhzen name ": Exit Sub



 '//////////////////////////////////////
 For Ro1 = 7 To Sheets.Count
 Set Find_Range = Sheets(Ro1).Range("C:C").Find(Third, LookAt:=1)
  If Not Find_Range Is Nothing Then
   ReDim Preserve arr(m)
   arr(m) = Sheets(Ro1).Name
   m = m + 1
  End If
MY_Next:
Next

  If m <> 0 Then
     MsgBox "رقم المستند مكرر فى الشيت: " & Chr(10) & _
     Join(arr, " ; ")
    Exit Sub
  End If


    'إيقاف اهتزاز الشاشة
Application.Calculation = xlManual
Application.ScreenUpdating = False
Application.EnableEvents = False
        'ورقة العمل المسماة صفحة الترحيل
        Set ws = Sheet2
        'المتغير لمعرفة رقم آخر صف به بيانات في العمود الثاني
        m = ws.Cells(Rows.Count, "B").End(xlUp).Row
        'حلقة تكرارية من الصف رقم 3 إلى آخر صف به بيانات
        For R = 3 To m
            'متغير لتخزين اسم ورقة العمل التي سيتم الترحيل إليها
            sName = ws.Cells(R, 5).Value
            'التأكد من وجود ورقة العمل التي سيتم الترحيل إليها
            If Evaluate("ISREF('" & sName & "'!A1)") Then
                'تعيين ورقة العمل التي سيتم الترحيل إليها
                Set Sh = ThisWorkbook.Worksheets(sName)
                'تحديد أول صف فارغ في ورقة العمل المراد الترحيل إليها لوضع البيانات بها
                n = Sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
                With Sh
                    'ترحيل التاريخ
                    .Cells(n, 1).Value = ws.Cells(2, 1).Value
                    'ترحيل الاسم
                    .Cells(n, 2).Value = ws.Cells(R, 2).Value
                    'ترحيل رقم الفاتورة
                    .Cells(n, 3).Value = ws.Cells(2, 3).Value
                    'معرفة رقم العمود الخاص بالمخزن ليتم إدراج المبلغ فيه
                    x = Application.Match(ws.Cells(2, 6).Value, Sh.Rows(2), 0)
                    If Not IsError(x) Then
                        .Cells(n, x).Value = ws.Cells(R, 4).Value
                    End If
                End With
            Else
                Debug.Print "Worksheet " & sName & " Doesn't Exist"
            End If
        Next R
    'استعادة خاصية اهتزاز الشاشة
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Application.EnableEvents = True
TR.Select
Answer = MsgBox("تم الترحيل هل تريد مسح" & Chr(10) & _
 "البيانات Then The Sheet" & Chr(10) & _
 """" & TR.Name & """", 36)
  If Answer = 6 Then
  CLEAR_ME
  End If
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Application.EnableEvents = True
 

End Sub

الكود يتوقف عند الجزء 
GoTo Next_Ro1

نص رسالة الخطأ
compile error
label not defined
بارك الله فى اصحاب الكود استاذ سليم اخى استاذ ياسر اخى


أفضل إجابة مقدمة من salim وهي:
حيث ان عدد الشيتات كبير جداً مما يجعل المستخدم يلاقي صعوبة في العثور على صفحة ما يريدها عندها اقترح هذا الملف الذي عند الحاجة للذهاب الى اي شيت يكفي ان تختارها من الكومبوبوكس فيقوم الماكرو باخفاء كافة الصفحات (ما عدا الصفحة الرئيسية) واظهار الصفحة التي تريدها  منفردة الى جانبها
  بالاضافة الى ميزة جديدة (بدون كود) هي عدم السماح بحذف اي صفحة من الملف
    (عن طريق الخطأ)    اواضافة اي صفحة  جديدة على الملف أو نسخ صفحة بكاملها
       بينما  يمكن نسخ خلية أو مجموعة خلايا

لرؤية كافة الصفحات اضغط على الزر Show all






 
عرض الإجابة




26-08-2020 09:27 مساء
مشاهدة مشاركة منفردة [1]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif ممكن توضيح اين الخطأ فى الكود المكون من تجميع كود للعلامة استاذ سليم والاستاذ ياسر
ضعي هذه العبارة كما في الصورة قي المكان المناسب
او يمكنك حذف   Goto_Next_Ro1
بدون اضافة شيء


0ihzY_Om Hamza

 
 
 


26-08-2020 11:34 مساء
مشاهدة مشاركة منفردة [2]
omhamzh
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 27-05-2020
رقم العضوية : 19308
المشاركات : 137
الجنس : أنثى
يتابعهم : 1
يتابعونه : 0
قوة السمعة : 225
 offline 
look/images/icons/i1.gif ممكن توضيح اين الخطأ فى الكود المكون من تجميع كود للعلامة استاذ سليم والاستاذ ياسر
ربنا يكرمك استاذ سليم الغالى
عند التنفيذ كما تكرمت واوضحت
الكود لم ينفذ جزء ان هل تريد ان اتجاوز وخرجت رسالة ادخال name
عندما نفذت الطريقتين
الكود لم يقول لى السطر فارغ هل تريد ان اتجاوز 
بل اخبرنى ادخل name
مشكور يا استاذ سليم يا كريم
 
 
 
  mr salim mr yasser.xlsb   تحميل xlsb مرات التحميل :(1)
الحجم :(35.945) KB


27-08-2020 06:00 صباحا
مشاهدة مشاركة منفردة [3]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif ممكن توضيح اين الخطأ فى الكود المكون من تجميع كود للعلامة استاذ سليم والاستاذ ياسر
تم التصحيح
و لكن الذي لا افهمه هو عملية دمج كودين يقومان بنفس المهمة في كود واحد

Sub test()
    Dim x, ws As Worksheet, Sh As Worksheet, sName As String, R As Long, m As Long, n As Long, rng As Range
        Dim TR As Worksheet
    Dim Find_Range
    Dim Frst As Range, Third As Range
    Dim Sixth As Range
    Dim My_rg As Range
    Dim Ro1%, Ro%, col%, Last_Ro%, i%
    Dim nEW_RO%, nEW_COL%
    Dim Answer As Byte
    Dim arr()

    Set TR = Sheets("transfer")
    Ro = TR.Cells(Rows.Count, 2).End(3).Row
    Set Frst = TR.Range("A2")
    Set Third = TR.Range("C2")
    Set Sixth = TR.Range("F2")
    Set My_rg = TR.Range("B4:E" & Ro)
      Dim XX%, cont%, Ro_E%
    Ro_E = TR.Cells(Rows.Count, "E").End(3).Row
  If Ro_E < 4 Then MsgBox "no data to transfer": Exit Sub

If Frst = "" Then MsgBox "Date ": Exit Sub
If Third = "" Then _
 MsgBox "namber ": Exit Sub
 For i = 4 To Ro_E
  Set Sh = Sheets(Cells(i, 5) & "")
  If TR.Cells(i, 3) = vbNullString Then
      MsgBox "ألخلية (" & My_rg.Cells(Ro1, 3).Address(0, 0) & ")" & _
      " في الورقة " & """" & TR.Name & """" & " فارغة" & Chr(10) & _
      "سأتجاوز هذا الأمر", vbMsgBoxRtlReading
'Next_Ro1:
  End If
Next
For Ro1 = 1 To My_rg.Columns(1).Cells.Count
If My_rg.Cells(Ro1, 4) = vbNullString Then
 MsgBox "sheet name"
 Exit Sub
End If
Next
 If Sixth = "" Then _
 MsgBox "makhzen name ": Exit Sub



 '//////////////////////////////////////
 For i = 2 To Sheets.Count
 Set Find_Range = Sheets(i).Range("C:C").Find(Third, LookAt:=1)
  If Not Find_Range Is Nothing Then
   ReDim Preserve arr(m)
   arr(m) = Sheets(i).Name
   m = m + 1
  End If
MY_Next:
Next

  If m <> 0 Then
     MsgBox "رقم المستند مكرر فى الشيت: " & Chr(10) & _
     Join(arr, " ; ")
    Exit Sub
  End If


    'إيقاف اهتزاز الشاشة
Application.Calculation = xlManual
Application.ScreenUpdating = False
Application.EnableEvents = False
        'ورقة العمل المسماة صفحة الترحيل
        Set ws = Sheet2
        'المتغير لمعرفة رقم آخر صف به بيانات في العمود الثاني
        m = ws.Cells(Rows.Count, "B").End(xlUp).Row
        'حلقة تكرارية من الصف رقم 3 إلى آخر صف به بيانات
        For R = 3 To m
            'متغير لتخزين اسم ورقة العمل التي سيتم الترحيل إليها
            sName = ws.Cells(R, 5).Value
            'التأكد من وجود ورقة العمل التي سيتم الترحيل إليها
            If Evaluate("ISREF('" & sName & "'!A1)") Then
                'تعيين ورقة العمل التي سيتم الترحيل إليها
                Set Sh = ThisWorkbook.Worksheets(sName)
                'تحديد أول صف فارغ في ورقة العمل المراد الترحيل إليها لوضع البيانات بها
                n = Sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
                With Sh
                    'ترحيل التاريخ
                    .Cells(n, 1).Value = ws.Cells(2, 1).Value
                    'ترحيل الاسم
                    .Cells(n, 2).Value = ws.Cells(R, 2).Value
                    'ترحيل رقم الفاتورة
                    .Cells(n, 3).Value = ws.Cells(2, 3).Value
                    'معرفة رقم العمود الخاص بالمخزن ليتم إدراج المبلغ فيه
                    x = Application.Match(ws.Cells(2, 6).Value, Sh.Rows(2), 0)
                    If Not IsError(x) Then
                        .Cells(n, x).Value = ws.Cells(R, 4).Value
                    End If
                End With
            Else
                Debug.Print "Worksheet " & sName & " Doesn't Exist"
            End If
        Next R
    'استعادة خاصية اهتزاز الشاشة
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Application.EnableEvents = True
TR.Select
Answer = MsgBox("تم الترحيل هل تريد مسح" & Chr(10) & _
 "البيانات Then The Sheet" & Chr(10) & _
 """" & TR.Name & """", 36)
  If Answer = 6 Then
  CLEAR_ME
  End If
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Application.EnableEvents = True
 

End Sub
'++++++++++++++++++++++++++++++++++++
Sub CLEAR_ME()
Dim My_sheet As Worksheet
Dim t%
Set My_sheet = Sheets("transfer")
With My_sheet
  t = .Cells(Rows.Count, 2).End(3).Row
  .Range("A3:E50" & t).ClearContents
  .Range("C2").ClearContents
  .Range("f2").ClearContents

 End With
End Sub


 
 
 
  correcrtion.xlsm   تحميل xlsm مرات التحميل :(7)
الحجم :(48.212) KB


27-08-2020 04:34 مساء
مشاهدة مشاركة منفردة [4]
omhamzh
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 27-05-2020
رقم العضوية : 19308
المشاركات : 137
الجنس : أنثى
يتابعهم : 1
يتابعونه : 0
قوة السمعة : 225
 offline 
look/images/icons/i1.gif ممكن توضيح اين الخطأ فى الكود المكون من تجميع كود للعلامة استاذ سليم والاستاذ ياسر
لاحرمنا منك يارب اسعد الله اوقاتك وايامك يارب
كل الشكر لك اخى الكريم اخى استاذ سليم مشكور

30-08-2020 08:23 مساء
مشاهدة مشاركة منفردة [5]
omhamzh
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 27-05-2020
رقم العضوية : 19308
المشاركات : 137
الجنس : أنثى
يتابعهم : 1
يتابعونه : 0
قوة السمعة : 225
 offline 
look/images/icons/i1.gif ممكن توضيح اين الخطأ فى الكود المكون من تجميع كود للعلامة استاذ سليم والاستاذ ياسر
معلش استاذ سليم salim انا والله من يومها عندى مشكلة الكود يعطينى الخلية d3 فارغة هل تريد تجاوزها اختار نعم فلا يتم الترحيل
والصف 3 كله فارغ بالطبع
انا اسفة والله حاولت جدااا وفشلت
بارك الله فيك

30-08-2020 09:25 مساء
مشاهدة مشاركة منفردة [6]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif ممكن توضيح اين الخطأ فى الكود المكون من تجميع كود للعلامة استاذ سليم والاستاذ ياسر
بارك الله فيك[/quote]
حضرتك عاملة دمج كودين في كود واحد
انا فقط استطيع ان اعالج ما أنا وضعته ولا أعرف ماذا يفعل الكود الثاني
لذلك ارفعي ملف بالكود الخاص بي فقط مع شرح ماذا تريدين بالتفصيل


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


الكلمات الدلالية
ممكن ، توضيح ، الخطأ ، الكود ، المكون ، تجميع ، للعلامة ، استاذ ، سليم ، والاستاذ ، ياسر ،


 










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

الساعة الآن 03:42 صباحا