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

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


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





الكود يتوقف ورسالة خطا

المطلوب عمل فصل حسب اسم العميل فى ورقة عمل منفصله واذا تكرر الاسم تنقل البيانات الى نفس الصفحه التى انشئت بإسمه



31-05-2020 11:06 مساء
احمد2004
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 31-12-2017
رقم العضوية : 2958
المشاركات : 27
الجنس : ذكر
تاريخ الميلاد : 22-12-1978
يتابعهم : 2
يتابعونه : 1
قوة السمعة : 55
 offline 

المطلوب عمل فصل حسب اسم العميل فى ورقة عمل منفصله واذا تكرر الاسم تنقل البيانات الى نفس الصفحه التى انشئت بإسمه
 
 
  test123.xlsm   تحميل xlsm مرات التحميل :(3)
الحجم :(17.105) KB


01-06-2020 07:41 صباحا
مشاهدة مشاركة منفردة [1]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif الكود يتوقف ورسالة خطا
جرب هذا الملف
1-تم تغيير اسم الصفحة الرئيسية الى  Principal   لحسن نقل الكود ولصقه
2-تم انشاء صفحة باسم  SH_to_copy  (مخفية) لنسخ الجدول منها
الكود

Option Explicit
Dim P As Worksheet, s As Worksheet
Dim Rg_copy As Range, Final_Rg As Range
Dim Cur_range As Range
Dim i%, K%, Ro%, t%
'++++++++++++++++++++++++++++++++++++++++++++
Sub Add_sheet()
 Rem created By salim on 1/6/2020
 Dim sh_n%
 Set P = Sheets("Principal"): Set s = Sheets("SH_to_copy")
 sh_n = Application.CountA(P.Range("B:B")) - 1

  s.Visible = -1
  For i = 2 To sh_n
   If Not (Application.Evaluate _
    ("ISREF('" & P.Range("B" & i) & "'!A1)")) Then
        s.Copy after:=Sheets(Sheets.Count)
     With ActiveSheet
       .Name = P.Range("B" & i)
       .Range("B2") = P.Range("B" & i)
     End With
   End If
    Next i
s.Visible = 2
P.Select
End Sub
'++++++++++++++++++++++++++++++++++
Sub get_dat()
 Rem created By salim on 1/6/2020
Add_sheet
t = 1
Dim Arr(), it
  For i = 3 To Sheets.Count
    ReDim Preserve Arr(1 To t)
    Arr(t) = Sheets(i).Name
    t = t + 1
  Next i
Ro = P.Cells(Rows.Count, 2).End(3).Row
For Each it In Arr

 Set Cur_range = Sheets(it).Range("B4").CurrentRegion
If Cur_range.Rows.Count > 1 Then _
 Cur_range.Offset(1) _
 .Resize(Cur_range.Rows.Count - 1).Clear
 For K = 2 To Ro
   If P.Cells(K, 2) = Sheets(it).Name Then
      If Rg_copy Is Nothing Then
       Set Rg_copy = P.Cells(K, 3).Resize(, 2)
      Else
       Set Rg_copy = _
        Union(Rg_copy, P.Cells(K, 3).Resize(, 2))
      End If
   End If
 Next K
 If Not Rg_copy Is Nothing Then
   Rg_copy.Copy Sheets(it).Range("C5")
   Set Final_Rg = Sheets(it).Range("B4").CurrentRegion
      If Final_Rg.Rows.Count > 1 Then
        With Final_Rg.Offset(1).Resize(Final_Rg.Rows.Count - 1)
         .Interior.ColorIndex = 35
         .InsertIndent 1
         .Font.Size = 16: .Font.Bold = True
         .Columns(1).Formula = "=ROWS($A$1:A1)"
         .Borders.LineStyle = 1
         .Value = .Value
        End With
      End If
  End If
     Set Rg_copy = Nothing
 Next it
End Sub

الملف مرفق للمعاينة


 
 
 
  Copy_data.xlsm   تحميل xlsm مرات التحميل :(3)
الحجم :(39.168) KB


01-06-2020 09:35 صباحا
مشاهدة مشاركة منفردة [2]
احمد2004
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 31-12-2017
رقم العضوية : 2958
المشاركات : 27
الجنس : ذكر
تاريخ الميلاد : 22-12-1978
يتابعهم : 2
يتابعونه : 1
قوة السمعة : 55
 offline 
look/images/icons/i1.gif الكود يتوقف ورسالة خطا
شكرا استاذ سالم على تجاوبك معايا وجزاك الله خير
ولكن سامحنى وارجو تكون طويل البال معايا انا بتعلم اكتب اكواد وعاوز اعرف الخطأ فى الكود بتاعى عشان اتعلم من خطأى لكن كود حضرتك جميل جدا ومتقدم ماشاء الله عليك .

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

01-06-2020 02:42 مساء
مشاهدة مشاركة منفردة [4]
الصقر
مدير المنتدى
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 2
المشاركات : 1824
الجنس : ذكر
الدعوات : 21
يتابعهم : 0
يتابعونه : 748
قوة السمعة : 19987
موقعي : زيارة موقعي
عدد الإجابات: 2
 offline 
look/images/icons/i1.gif الكود يتوقف ورسالة خطا

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

توقيع :الصقر

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


01-06-2020 08:48 مساء
مشاهدة مشاركة منفردة [5]
احمد2004
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 31-12-2017
رقم العضوية : 2958
المشاركات : 27
الجنس : ذكر
تاريخ الميلاد : 22-12-1978
يتابعهم : 2
يتابعونه : 1
قوة السمعة : 55
 offline 
look/images/icons/i1.gif الكود يتوقف ورسالة خطا
142شكرا جزيلا على اللفته الطيبه .
والشكر موصول للجميع
 




الكلمات الدلالية
ورسالة ، يتوقف ، الكود ،


 










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

الساعة الآن 06:57 مساء