يوسف عطا

عزيزى الغالى رجب بك جاويش أولاً أشكرك على إهتمامك وأعتذر عن التأخر فى متنابعة الموضوع لوجود مشاكل فى الكمبيوتر كنت أقوم بإصلاحها بالنسبة للجزء الذى ذكرته سيادتكم بخصوص أن الكود يتعامل مع رقم الشيت وليس مع إسمه الذى يوجد غالباً بين القوسين هل يمكن تعديل الكود ليتعامل مع إسم الشيت وليس رقمه ؟؟ بالطبع من السهل تغيير الكود بالطريقة التى ذكرتها سيادتكم ولكن تحسباً لإحتياجى للكود فى أعمال أخرى ياريت التعديل يتم على اساس التعامل مع إسم الشيت الموجود فى علامة تبويب الشيت والذى يوجد بين القوسين ألف شكر يا الغالى وأعتقد أنك لن تحتاج لملف مرفق فقد قمت بعمل ملف مشابه وإن كان لابد من الإرفاق إخبرنى فأرفق نسخة محدودة من الملف لأن الملف الأصلى الذى أعمل عليه كبير جداً مع العلم بأن الكود فعلاً اصبح يعمل تمام التمام بعد تغيير السطر الأول والتاسع فى الجزء الأخير كما يلى للتعامل كما ذكرت سيادتكم مع رقم الشيت وليس إسمه فهل يمكن تعديل الجزء التالى من الكود ليتعامل مع إسم الشيت وليس رقمه ؟؟ مع العلم أنه يقوم بإستخراج إحصائية الترحيلات بعد الترحيل For Y = 2 To 4 Sheets(Y).[B11] = 1 rrw = Sheets(Y).[B3000].End(xlUp).Row For Each cc In Sheets(Y).Range("B12:B" & rrw) cc.Value = cc.Offset(-1, 0) + 1 Next cc Next Y MsgBox ("الحمد لله تـــم ترحيل الطالبات كل إلى شيت نتيجتها طبقاً للإحصاء التالى ") For x = 2 To 4 Y = Sheets(x).[B3000].End(xlUp).Row - 10 mssg = mssg & Chr(10) & Format(Y, "00") & " Students to Sheet : " & x Next x MsgBox (" تم ترحيل عدد" & mssg) Range("A1").Select Application.ScreenUpdating = True End Sub

قمت بالفورمات أمس وبتجربة الكود الذى يستخرج رقم الهارد ديسك فى ويندو برسالة إكتشفت أنه تغير أى أن هذا الكود لا يستخرج الرقم الحقيقى للهارد كما أن طريقة المعادلتان كذلك لم تعطيانى نفس الأرقام بعد الفورمات وإليكم الأرقام قبل وبعد الفورمات وكل معادلة المعادلة 1 HDSerialNumber() أول نتيجة 12B1-CF33 بعد الفورمات C04C-E2E2 المعادلة الثانية GetPhysicalSerial() أول نتيجة WD-WMAVU2718655 بعد الفورمات 2020202057202d444d5756413255313736383535

كود الترحيل هذا كان يعمل تمام التمام عند نقله إلى ورقة أخرى مع تعديل طفيف أصبح لا يعمل الكود يرحل البيانات من شيت رقم 23 إلى شيتات رقم 24 و 25 و 26 معيار الترحيل موجود فى أول عمود Dim Z As Integer, A As Integer, B As Integer, C As Integer Sheets("24").Range("A11:DZ5000").ClearContents Sheets("25").Range("A11:DZ5000").ClearContents Sheets("26").Range("A11:DZ5000").ClearContents A = 11: B = 11: C = 11 Application.ScreenUpdating = False For Z = 11 To 5000 If Cells(Z, 1) = "ناجحة" Then Range("A" & Z).Resize(1, 33).Copy Sheets("24").Range("A" & A).PasteSpecial xlPasteValues Application.CutCopyMode = False A = A + 1 End If If Cells(Z, 1) = "لها حق" Then Range("A" & Z).Resize(1, 33).Copy Sheets("25").Range("A" & B).PasteSpecial xlPasteValues Application.CutCopyMode = False B = B + 1 End If If Cells(Z, 1) = "ليس لها حق" Then Range("A" & Z).Resize(1, 33).Copy Sheets("26").Range("A" & C).PasteSpecial xlPasteValues Application.CutCopyMode = False C = C + 1 End If Next For Y = 24 To 26 Sheets(Y).[B11] = 1 rrw = Sheets(Y).[B3000].End(xlUp).Row For Each cc In Sheets(Y).Range("B12:B" & rrw) cc.Value = cc.Offset(-1, 0) + 1 Next cc Next Y MsgBox ("الحمد لله تـــم ترحيل الطالبات كل إلى شيت نتيجتها طبقاً للإحصاء التالى ") For x = 24 To 26 Y = Sheets(x).[B3000].End(xlUp).Row - 10 mssg = mssg & Chr(10) & Format(Y, "00") & " Students to Sheet : " & x Next x MsgBox (" تم ترحيل عدد" & mssg) Range("A1").Select Application.ScreenUpdating = True End Sub

بالفعل أخى محمود هذه الطريقة تؤدى الغرضأشكرك على إهتمامك

للأسف أخوتى الأعزاء لم يفلح الكود وتعديله مع إنى جربته في ملف آخر وتم التنفيذ لكن مش عارف ليه مش شغال على ملفى

شاكرين الأفضال أيها الأخوة الأعزاء أعزكم الله جميعاً

ممكن حد يحطلنا رابط لبرنامج أوفيس 2013 عربى بس يكون مجرب وكامل ؟؟

أخوتى الأفاضل السلام عليكم تعبتكم معايا ألأف شكر لكما أخى الغالى خبور خير أخى الغالى أبو نصار دمتما بود

الف شكر أخونا الغالى رجب بك جاويس

بعد إذن الأخوة الأفاضل هل يمكن تعديل المعادلة لتقوم بتلوين الإسم المكرر فى عمودين مثلاً العمود B والعمود H بحيث يتم تظليل الإسم المشترك فى العمودين

نحن فى إنتظار تبيان هلى النسخة العربية تعمل تمام التمام أم لا كذلك ياريت تعرفنا ما الجديد فى النسخة 2013 مع الشكر

الحل من وجهة نظرى هو بإستخدام التنسيق الشرطى لتظليل الأسماء المكررة ثم التعامل معها يدوياً بعد ذلك وقد سبق الأخ محمود أن أفادنا بإحدى معادلات التنسيق الشرطى التى تقوم بذلك ولكن لا أذكرها وجارى البحث عنها

لدى ملف به عمودين من الأسماء 1 به 1100 إسم والعمود الثانى به 1300 إسم منها 1000 إسم بالعمود الأول المطلوب 1. أن أحدد الأسماء فى العمود الثانى التى لا توجد فى العمود الأول بتظليلها 2. أحدد الأسماء فى العمود الأول التى لا توجد فى العمود الثانى بتظليلها أو البديل تظليل الأسماء المكررة فى العمودين الأسماء بالعمودين B , H

لم يظبط معى ايضاً أخى الغالى مرفق الملف والمفروض أن زر التنقل بين الصفحات فى الورقة رقم 2 فى العمود H والكود موجود فى موديول رقم 11 وأسماء الشيتات يمكن الوصول إليها من شيت رقم 32 أو من شيت ماى ديت وفى حالة غستخدام شيت رقم 32 يمكن إستخدام الجدول الطولى أو الجدول العرضى حسب ما يحلو لكم اليوزر يوسف الباس 111 تم الضغط مرتين لأن حجم الملف كان كبير الف شكر مجلد جديد.rar

جارى التجربة أخى الغالى والملف مفتوح أمامى بالفعل هل أضع الاسطر السابقة مكان السطر الذى يعطينى إرور ؟ أم ماذا ؟

يمكن إستخدام دالة =CONCATENATE(*;*;*;*) بحيث توضع مكان النجوم الخلايا التى بها الأسماء المراد تجميعها

لا أعرف السبب بالضبط ولكن الملف عندى يعمل تماماً وقد جربته على أكتر من جهاز

للرفع رفع الله قدركم

أخى أبو نصار لدى ملف به عدة أكواد في ThisWorkbook وعندما أردت إضافة الكود الذى أرفقته سيادتكم حدث تضارب مع الأكواد الأخرى مرفق الأكواد برجاء التكرم بإيجاد حل لتعمل الأكواد الثلاثة معاً من نفس الحدث وكذلك أى كود جديد سنضيفه إلى الحدث فيما بعد Private Const A As String = " WD-WMAVU2718655" Private Const B As String = "2020202057202d444d5754413431343631363732" Private Const C As String = " WD-WMAT14382851" Private Sub Workbook_Open() Dim s As String With GetObject("winmgmts:\\.\root\CIMV2") For Each itm In .ExecQuery("SELECT * FROM Win32_DiskDrive", , 48) s = s & itm.SerialNumber Next itm End With Debug.Print "C :" & C & " " & "s :" & s If s = A Or s = B Or s = C Then MsgBox "تم التأكد من الجهاز بنجاح ", vbInformation, "تفضل بالدخول" Else MsgBox "هذا البرنامج يعمل على أجهزة معينه فقط", vbInformation, "سيتم إغلاق البرنامج" With ActiveWorkbook .Close .Saved = True End With Exit Sub End If End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Workbook_Open() For i = 1 To Sheets.Count Sheets("MyDate").Cells(3, i + 4) = Sheets(i).Name Next UserForm1.Show End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Workbook_BeforeClose(Cancel As Boolean) Sheets("1").Activate For i = 2 To Sheets.Count Sheets(i).Unprotect Next ThisWorkbook.Save End Sub

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

الأخ الغالى دغيدى بك الصورة السفلى توضح سيريال الفلاشة وكذلك سيريال الهارد لاحظ أن السطر الأول سيريال الفلاشة نصف السطر الثانى الأول نوع الفلاشة وماركتها وطريقة توصيلها نصف السطر الثانى الثانى سيريال الهارد السطر الثالث نوع الهارد وموديله وطريقة توصيله مع تحياتى

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

أما بخصوص كود الترحيل أخى الغالى دغيدى فهو جميل جداً وسهل جداً ولو تتكرم بشرحه يجازيك الله عنا خيراً

بعد إذن أخى جمال بك دغيدى ولإثراء الموضوع بقترح الكود التالى لنسخ النتيجة مع فرزها لشيت الكل مع الإستغناء عن ماكرو معادلة إف فى الشيت الرئيسى يراعى تسمية الشيت الرئيسى (الشيت) قبل تنفيذ الكود Sub فرزص() Sheets("الشيت").Select Range("A11:DO10000").Select Selection.Copy Sheets("الكل").Select Range("A11").Select ActiveSheet.Paste Range("DO11").Select ActiveCell.FormulaR1C1 = _ "=IF(RC[-1]="""","""",IF(RC[-1]=""ناجح"",1,IF(RC[-1]=""راسب"",2,IF(RC[-1]=""غائب"",3))))" Range("DO11").Select Selection.AutoFill Destination:=Range("DO11:DO10000") Range("A11:DO10000").Select Selection.Sort Key1:=Range("DO11"), Order1:=xlAscending, Header:=xlNo, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal MsgBox "تم نسخ النتيجة وترتيبها فى شيت الكل" End Sub

أولاً تضع الكود فى موديول ثانياً تصنع زر لإستدعاء الكود بمجرد كبس هذا الزر تظهر لك نتيجة الكود الملف مرفق إستخراج رقم الهارد ديسك.rar