logo

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
noureddine70 لا تميز خلال هذه الفترة-- لا تميز خلال هذه الفترة YasserKhalil برنامج فك حماية محرر الأكواد VBA وحماية unviewable اكسيل اسئله واجابات



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





02-04-2020 12:47 مساءً
السلام عليكم ورحمة الله وبركاته ,
إخواني الأعزاء عسى أن تكونوا جميعكم بخير , أرفق لكم ملف والمطلوب 1- تعديل على كود الترحيل ( عدم تكرار الترحيل مع رسالة تفيد بذلك )
2- كما يوجد سجل مفلتر المطلوب عند الفلترة ان يظهر المجاميع للمفلتر له وحده دون غيره
ولكم جزيل الشكر , تحياتي لكم جميعا مشرفين وأعضاء
 
 
  Book10.rar   تحميل rar مرات التحميل :(6)
الحجم :(40.638) KB





look/images/icons/i1.gif تعديل واضافة كود
  02-04-2020 05:46 مساءً   [1]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-09-2017
رقم العضوية : 576
المشاركات : 102
الدولة : مصر
الجنس :
تاريخ الميلاد : 14-11-1974
قوة السمعة : 649
الاعجاب : 0
وعليكم السلام ورحمة الله وبركاته Book10.rar
 
 
  Book10.rar   تحميل rar مرات التحميل :(11)
الحجم :(49.092) KB


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



look/images/icons/i1.gif تعديل واضافة كود
  02-04-2020 10:53 مساءً   [2]
معلومات الكاتب ▼
تاريخ الإنضمام : 02-04-2020
رقم العضوية : 18741
المشاركات : 23
الجنس :
تاريخ الميلاد : 13-11-1972
قوة السمعة : 30
الاعجاب : 0
السلام عليكم ورحمة الله وبركاته ,
أستاذ ابو نور قمت بنقل زر ترحيل البيانات الى الصفحة الرئيسية ولكن يعد يعمل بشكل جيد , كيف أصلح هذه المشكلة
جزاكم الله خيرا

أثارت هذه المشاركة إعجاب: عبدالله فتحى،



look/images/icons/i1.gif تعديل واضافة كود
  03-04-2020 01:53 مساءً   [3]
معلومات الكاتب ▼
تاريخ الإنضمام : 02-04-2020
رقم العضوية : 18741
المشاركات : 23
الجنس :
تاريخ الميلاد : 13-11-1972
قوة السمعة : 30
الاعجاب : 0
ارفق لكم الملف
مع خالص تحياتي
 
 
  ابونور.rar   تحميل rar مرات التحميل :(1)
الحجم :(301.929) KB





look/images/icons/i1.gif تعديل واضافة كود
  03-04-2020 04:34 مساءً   [4]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-09-2017
رقم العضوية : 576
المشاركات : 102
الدولة : مصر
الجنس :
تاريخ الميلاد : 14-11-1974
قوة السمعة : 649
الاعجاب : 0
 
 
  Book10.rar   تحميل rar مرات التحميل :(5)
الحجم :(307.434) KB


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



look/images/icons/i1.gif تعديل واضافة كود
  03-04-2020 05:33 مساءً   [5]
معلومات الكاتب ▼
تاريخ الإنضمام : 02-04-2020
رقم العضوية : 18741
المشاركات : 23
الجنس :
تاريخ الميلاد : 13-11-1972
قوة السمعة : 30
الاعجاب : 0
أستاذ ابو نور الله يعطيك العافية وجزاك الله خيراً. أمور الترحيل تمام
ولكن امر الطباعة يعطي بأنه هنالك خطأ هنا ("Set rng = Sheets("Sheet18").Range("A1:A312

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



look/images/icons/i1.gif تعديل واضافة كود
  04-04-2020 01:20 صباحاً   [6]
معلومات الكاتب ▼
تاريخ الإنضمام : 12-08-2018
رقم العضوية : 7616
المشاركات : 133
الجنس :
تاريخ الميلاد : 11-5-1992
الدعوات : 2
قوة السمعة : 571
الاعجاب : 2
اخى لان اسم الشيت اللى هوsheet18غير موجود بملفك غير هذا الاسم بالاسم الجديد اى اللتى بها امر الطباعة،الاسم يكتب بين قوسين التنصيص

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



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

Sub My_Code()

Dim H As Worksheet, Nakl As Worksheet
Dim S As Worksheet
Dim lr_h%, lr_S, Newlr_h%, newlr_S%
Dim Cop_rg5 As Range, Cop_rg10 As Range
  Set H = Sheets("الهيئة"): Set Nakl = Sheets("للنقل")
  Set S = Sheets("السجل")
  Set Cop_rg5 = Nakl.Range("B5").Resize(, 11)
  Set Cop_rg10 = Nakl.Range("B10").Resize(, 7)

lr_S = S.Cells(Rows.Count, 2).End(3).Row + 1
If lr_S <= 4 Then lr_S = 4
lr_h = H.Cells(Rows.Count, 2).End(3).Row + 1
If lr_h <= 4 Then lr_h = 5
    Cop_rg5.Copy: H.Range("b" & lr_h).PasteSpecial
    Cop_rg10.Copy: S.Range("b" & lr_S).PasteSpecial
    
    Newlr_h = H.Cells(Rows.Count, 2).End(3).Row
    newlr_S = S.Cells(Rows.Count, 2).End(3).Row
    H.Select
 Call remove_dupliacte(H.Range("b5:L" & Newlr_h), 11)
  Newlr_h = H.Cells(Rows.Count, 2).End(3).Row
  If Newlr_h = 5 Then
   S.Cells(5, 1) = 1
  Else
 H.Cells(5, 1).Resize(Newlr_h - 4).Formula = "=IF(B5="""","""",MAX($A$4:A4)+1)"
    End If
    S.Select
 Call remove_dupliacte(S.Range("b4:H" & newlr_S), 7)
 newlr_S = S.Cells(Rows.Count, 2).End(3).Row
  If newlr_S = 4 Then
  S.Cells(4, 1) = 1
  Else
S.Cells(4, 1).Resize(newlr_S - 2).Formula = "=IF(B4="""","""",MAX($A$3:A3)+1)"
  End If
  H.Range("a4").CurrentRegion.Borders.LineStyle = 1
  S.Range("a4").CurrentRegion.Borders.LineStyle = 1
 Nakl.Select
 Cop_rg5.ClearContents: Cop_rg10.ClearContents
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub remove_dupliacte(rg As Range, x)
Dim i%, lr, Answer As Byte
Dim col As New Collection
Dim arr, Rg_Del As Range
rg.Rows.Hidden = False
lr = rg.Columns(2).Rows.Count
For i = 3 To lr

If rg.Cells(i, 2) = vbNullString Then GoTo next_i

arr = Application.Transpose(Application.Transpose(rg.Cells(i, 2).Resize(, x)))
arr = Join(arr, "*")
On Error Resume Next
col.Add i, arr
If Err.Number > 0 Then
     If Rg_Del Is Nothing Then
       Set Rg_Del = rg.Cells(i, 1)
     Else
       Set Rg_Del = Union(Rg_Del, rg.Cells(i, 1))
     End If
    On Error GoTo 0
End If
next_i:
Next
 If Not Rg_Del Is Nothing Then
 
  Answer = MsgBox("You have Dulicates in :" & Rg_Del.Address & Chr(10) & _
   "Do you want to delete them", 4)
    If Answer = 6 Then
    Rg_Del.EntireRow.Delete
    End If
  End If
End Sub


الملف مرفق
 
 
  Salim_Book10.xlsm   تحميل xlsm مرات التحميل :(4)
الحجم :(54.741) KB


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



look/images/icons/i1.gif تعديل واضافة كود
  04-04-2020 11:08 صباحاً   [8]
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس :
تاريخ الميلاد : 1-5-1989
الدعوات : 1
قوة السمعة : 6611
الاعجاب : 2
تعديل بسيط على الكود لازالة كل المكرر دفعة واحدة
CODE

Sub My_Code()

Dim H As Worksheet, Nakl As Worksheet
Dim S As Worksheet
Dim lr_h%, lr_S, Newlr_h%, newlr_S%
Dim Cop_rg5 As Range, Cop_rg10 As Range
  Set H = Sheets("الهيئة"): Set Nakl = Sheets("للنقل")
  Set S = Sheets("السجل")
  Set Cop_rg5 = Nakl.Range("B5").Resize(, 11)
  Set Cop_rg10 = Nakl.Range("B10").Resize(, 7)

lr_S = S.Cells(Rows.Count, 2).End(3).Row + 1
If lr_S <= 4 Then lr_S = 4
lr_h = H.Cells(Rows.Count, 2).End(3).Row + 1
If lr_h <= 4 Then lr_h = 5
    Cop_rg5.Copy: H.Range("b" & lr_h).PasteSpecial
    Cop_rg10.Copy: S.Range("b" & lr_S).PasteSpecial
    
    Newlr_h = H.Cells(Rows.Count, 2).End(3).Row
    newlr_S = S.Cells(Rows.Count, 2).End(3).Row
    H.Select
 Call remove_dupliacte(H.Range("b5:L" & Newlr_h), 11)
  Newlr_h = H.Cells(Rows.Count, 2).End(3).Row
  If Newlr_h = 5 Then
   S.Cells(5, 1) = 1
  Else
 H.Cells(5, 1).Resize(Newlr_h - 4).Formula = "=IF(B5="""","""",MAX($A$4:A4)+1)"
    End If
   H.Range("a4").CurrentRegion.Borders.LineStyle = 1
    S.Select
 Call remove_dupliacte(S.Range("b4:H" & newlr_S), 7)
 newlr_S = S.Cells(Rows.Count, 2).End(3).Row
  If newlr_S = 4 Then
  S.Cells(4, 1) = 1
  Else
S.Cells(4, 1).Resize(newlr_S - 2).Formula = "=IF(B4="""","""",MAX($A$3:A3)+1)"
  End If
  S.Range("a4").CurrentRegion.Borders.LineStyle = 1
 Nakl.Select
 Cop_rg5.ClearContents: Cop_rg10.ClearContents
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub remove_dupliacte(rg As Range, x)
Dim i%, lr, Answer As Byte
Dim col As New Collection
Dim arr, Rg_Del As Range
rg.Rows.Hidden = False
lr = rg.Columns(1).Rows.Count + 4

For i = 1 To lr

If rg.Cells(i, 1) = vbNullString Then GoTo next_i

arr = Application.Transpose(Application.Transpose(rg.Cells(i, 2).Resize(, x)))
arr = Join(arr, "*")
On Error Resume Next
col.Add i, arr
If Err.Number > 0 Then
     If Rg_Del Is Nothing Then
       Set Rg_Del = rg.Cells(i, 1)
     Else
       Set Rg_Del = Union(Rg_Del, rg.Cells(i, 1))
     End If
    End If
next_i:
Next
If Rg_Del Is Nothing Then Exit Sub
   Rg_Del.Interior.ColorIndex = 6
   Answer = MsgBox("You have Dulicates in :" & Rg_Del.Address & Chr(10) & _
   "Do you want to delete them", 4)
    If Answer = 6 Then
    Rg_Del.EntireRow.Delete
    End If

End Sub

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



look/images/icons/i1.gif تعديل واضافة كود
  04-04-2020 02:25 مساءً   [9]
معلومات الكاتب ▼
تاريخ الإنضمام : 02-04-2020
رقم العضوية : 18741
المشاركات : 23
الجنس :
تاريخ الميلاد : 13-11-1972
قوة السمعة : 30
الاعجاب : 0
السلام عليكم ورحمة الله وبركاته
أستاذ salim الكود اكثر من رائع ولكنه قام بنقل البيانات في السجل الاول(الهيئة) بشكل ممتاز واخفى الخلايا الفارغه ام السجل الثاني به خطأ . يرجى العلم بان البيانات ( والموجوده في صفحة للنقل )هي معلومات منقولة من عدة صفحات . يرجى الاطلاع على الملف المرفق ولكم جزيل الشكر .
 
 
  4-4-2020.rar   تحميل rar مرات التحميل :(2)
الحجم :(385.675) KB





look/images/icons/i1.gif تعديل واضافة كود
  04-04-2020 08:02 مساءً   [10]
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس :
تاريخ الميلاد : 1-5-1989
الدعوات : 1
قوة السمعة : 6611
الاعجاب : 2
الملف يحتوي على الكثير من الاوراق والكثير من الماكرات ولا وقت لمعرفة عمل كل ماكرو
حاولت تعديل الماكرو الذي وضعته لك و اصبح ينقل المعلومات دون أخطاء
 
 
  My_copy Copy (2).xlsm   تحميل xlsm مرات التحميل :(8)
الحجم :(411.287) KB


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



look/images/icons/i1.gif تعديل واضافة كود
  05-04-2020 11:36 صباحاً   [11]
معلومات الكاتب ▼
تاريخ الإنضمام : 02-04-2020
رقم العضوية : 18741
المشاركات : 23
الجنس :
تاريخ الميلاد : 13-11-1972
قوة السمعة : 30
الاعجاب : 0
جزاكم الله خيرا , ماقصرتوا .
شاكر افضالكم 142

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



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



المواضيع المتشابهه
عنوان الموضوع الكاتب الردود الزوار آخر رد
تعديل كود اسئلة مادة الرياضيات بطريقة الاتمتة صالح ربيع
3 812 Saleh Ahmed Rabie
طلب تعديل في ترحيل بيانات بشروط خاصة في الترحيل بكار للأبد
1 54 بكار للأبد
هل يمكن الاستدعاء بشرطين أو أكثر بالتعديل على هذا الكود أبو يوسف النجار
5 1502 تاج الدين
امل المساعد في تعديل المعادلة التي تحسب المدة المتبقية على تاريخ معين بحيث يختفي عندما يتم كتابة تم ابوعلي الحبيب
0 126 ابوعلي الحبيب
تعديل ملف حساب مرتب صلاح الصغير
0 107 صلاح الصغير

الكلمات الدلالية
تعديل ، واضافة ،









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

الساعة الآن 06:46 AM