ياسر خليل أبو البراء

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

أخي الكريم مجدي الطيب جرب الكود التالي (قمت بتغيير اسم المصنف للغة الإنجليزية ..يمكنك تسميته باللغة العربية وتعديل الاسم في الكود ..فقط لسهولة التعامل مع الكود قمت بتغيير اسم المصنف ) Sub ImportData() Dim WB As Workbook, rngLookup As Range Dim myRow As Long Dim shMain As Worksheet Application.ScreenUpdating = False Set shMain = ThisWorkbook.ActiveSheet Set WB = Workbooks.Open(ThisWorkbook.Path & "\" & "Data Base.xlsx") Set rngLookup = WB.ActiveSheet.Range("B3:B" & WB.ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row) On Error Resume Next With shMain myRow = Application.WorksheetFunction.Match(.Range("B1"), rngLookup, 0) + 2 Union(.Range("C8"), .Range("K8"), .Range("D11"), .Range("C14"), .Range("G14"), .Range("K14")).ClearContents .Range("C8") = WB.ActiveSheet.Cells(myRow, "C") .Range("K8") = WB.ActiveSheet.Cells(myRow, "E") .Range("D11") = WB.ActiveSheet.Cells(myRow, "D") .Range("C14") = WB.ActiveSheet.Cells(myRow, "F") .Range("G14") = WB.ActiveSheet.Cells(myRow, "G") .Range("K14") = WB.ActiveSheet.Cells(myRow, "H") End With WB.Close False Application.ScreenUpdating = True End Sub لا تنسى أن تحدد أفضل إجابة وأن تضغط على كلمة "أعجبني هذا" إذا نالت المشاركة إعجابكم تقبل تحياتي Import Data From Closed Workbook.rar

الأخ الكريم وجدي قم بوضع الكود التالي في حدث الفورم Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If (Shift = 2 And KeyCode = vbKeyV) Or (Shift = 1 And KeyCode = vbKeyInsert) Then KeyCode = 0 End If End Sub Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) Select Case KeyAscii Case vbKey0 To vbKey9, vbKeyBack, vbKeyClear, vbKeyLeft, vbKeyRight, vbKeyUp, vbKeyDown, vbKeyTab Case Else KeyAscii = 0 Beep End Select End Sub Private Sub CommandButton1_Click() If TextBox1.Value <> "" Then MsgBox TextBox1.Value Unload Me End Sub للتعامل مع الأرقام الصحيحة فقط Restrict TextBox Entry To Whole Numbers.rar

أخي الكريم أحمد بعد إذن أساتذتي إليك الحل التالي به شرح للكود لتعرف كيف تعدل عليه بما يناسب ملفك الأصلي Sub FinalResult() 'يقوم الكود بتجميع البيانات من ورقتي العمل اسئلة واجابة 'لتظهر النتائج النهائية بها [Final] قم بإنشاء ورقة عمل باسم '---------------------------------------------------------- 'الإعلان عن المتغيرات Dim shQ As Worksheet, shAns As Worksheet Dim I As Long, X As Long 'تعيين أوراق العمل التي بها البيانات المراد التعامل معها Set shQ = Sheets("اسئلة"): Set shAns = Sheets("اجابة") 'تعيين المتغير ليساوي واحد وهو رقم أول صف في ورقة النتائج X = 1 'مسح بيانات الأعمدة من الأول للخامس في ورقة النتائج Sheets("Final").Columns("A:E").ClearContents 'بدء التعامل مع ورقة الأسئلة With shQ 'نسخ النطاق في العمود الخامس إلى آخر خلية بها بيانات .Range("E2:E" & .Cells(Rows.Count, "E").End(xlUp).Row).Copy 'لصق البيانات في ورقة النتائج في أول خلية بالعمود الخامس Sheets("Final").Range("E1").PasteSpecial xlPasteValues End With 'بدء التعامل مع ورقة اجابة With shAns 'حلقة تكرارية تمثل صفوف الورقة من الصف الثاني إلى آخر صف به بيانات For I = 2 To .Cells(Rows.Count, "A").End(xlUp).Row 'النطاق في ورقة النتائج في الصف الأول يساوي النطاق في ورقة اجابة بامتداد ثلاثة أعمدة Sheets("Final").Range("A" & X).Resize(1, 3).Value = .Cells(I, 1).Resize(1, 3).Value 'زيادة المتغير بمقدار 6 للانتقال إلى الصف المناسب للبيانات التالية X = X + 6 Next I End With 'إلغاء خاصية القص والنسخ Application.CutCopyMode = False End Sub قم بإنشاء ورقة عمل باسم Final أرجو أن يكون المطلوب Insert Rows.rar

مشكور على مرورك العطر بالموضوع أخي وحبيبي في الله أبو يوسف بارك الله فيك وجزيت خير الجزاء

مشكور على الهدية القيمة بارك الله فيك وجزاك الله خير الجزاء

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

أو يمكن استخدام هذا الكود بدون اللجوء إلى استخدام طريقة النسخ أو الحلقات التكرارية Sub CopyRowActiveCell() Dim WS As Worksheet, SH As Worksheet, LR As Long Set WS = Sheets("بيانات"): Set SH = Sheets("مستودع") LR = SH.Cells(Rows.Count, 1).End(xlUp).Row + 1 SH.Cells(LR, 1).Resize(1, 6).Value = WS.Cells(ActiveCell.Row, 1).Resize(1, 6).Value End Sub

كشفت عن اللغة طلعت تايلاندي ..!!!! وأنا يدوب ثقافتي شوية عربي

رائع أخي الحبيب ياسر فتحي جزيت خير الجزاء على كل ما تقدمه يبدو أن الملف يحتاج لخطوط معينة حيث أنه يظهر في معظم الملف حروف غريبة .. ما هي لغة الملف ..هل هي إنجليزية وإذا كان الأمر كذلك ..ما هي الخطوط المستخدمة ؟؟ تظهر الحروف معي بهذا الشكل - LEFT คือ การตัดจำนวนตัวอักษรที่อยู่ทางซ้าย Column ตามจำนวนที่กำหนด شكله عبري

بارك الله فيك أخي الحبيب مختار إليك كود آخر لا يرقى لمستوى كودك بالطبع ..فكودك هو الأيسر والأسهل Sub CopyRowActiveCell() Dim WS As Worksheet, SH As Worksheet Dim lrWS As Long, lrSH As Long, I As Long Set WS = Sheets("بيانات"): Set SH = Sheets("مستودع") lrWS = ActiveCell.Row lrSH = SH.Cells(Rows.Count, 1).End(xlUp).Row + 1 For I = 1 To 6 SH.Cells(lrSH, I) = WS.Cells(lrWS, I) Next I End Sub

أخي الكريم طلبك غير واضح حاول توضح بملف مرفق أو بشكل النتائج المتوقعة

أخي أشرف لابد من مزيد من التوضيح تقصد استخراج كل مجموعة بيانات لكل توجيه في مصنف (ملف) .. ما هو الامتداد المرغوب ؟ ما هو المسار المراد تصدير البيانات إليه ؟ ما هي آلية العمل ؟ أقصد هل كل توجيه له زر أمر منفصل أم تريد عمل زري أمر أحدهما يتسخرج كل توجيه على حدا والآخر يستخرج جميع التوجيهات ؟ ما هي شكل النتائج المتوقعة في النهاية ؟ أقصد هل هناك أعمدة سيتم حذفها أم أنه لا يتم الإبقاء إلا على عمودين فقط عمود الاسم وعمود م. الترتيب؟ لا يفترض ان أسأل .. بل يفترض أن توضح كل ما سبق دون سؤال حتى لا يتشعب الموضوع بدون داعي لابد أن تعلم أن توضيح المسألة يمثل 90% من الحل

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

بدون تطبيقه على ملفك الأصلي .. الكود مجرد عمل معاينة هل اشتغل الكود معك أم أعطاك رسالة خطأ ؟؟ أم أنه نفذ عملية المعاينة للطباعة ؟؟ لم تذكر أي تفاصيل عموماً جرب تغير كلمة PrintPreview إلى Printout لتنفيذ الطباعة

لم أفهم استفسارك بشكل جيد ولكن قم بالتعديل على الأوراق ونفذ الأمر وشوف النتائج ... النتائج متجددة كلما نفذت الكود تقبل تحياتي

ارفق ملفك بعد ضغطه لتجد المساعدة

الأخ الكريم كل عام وأنت بخير طلبنا منك مراراً تغيير اسم الظهور للغة العربية بالنسبة لطلبك جرب استخدام دالة Sumif شوف الملف المرفق هل يؤدي بالغرض أم لا؟ مجمع وأوراق 2.rar

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

أخي أيمن أقواس الكود تكون بهذا الشكل <> انقر هذه العلامة <> ثم الصق ما تريده من معادلات وأكواد بداخلها لتظهر مثل هذا الشكل

بدون عملية النسخ يمكن استخدام الكود بهذا الشكل Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(ActiveCell, Range("A2:A5000")) Is Nothing Then Application.ScreenUpdating = False Sheets("مستودع").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = ActiveCell Application.ScreenUpdating = True End If End Sub يوضع الكود في حدث ورقة العمل

السطر ذو اللون الأصفر يعني وجود خطأ .. يرجى إدراج هذا السطر في المشاركة الخاصة بك للإطلاع عليه ويمكن لأحد الأخوة الذين جربوا الكود أن يعلمونا بالنتيجة لمعرفة عمل الكود من عدمه لأن الكود يعمل معي بدون مشاكل

أخي الكريم خالد يمكن نسخ بيانات الخلية النشطة بدون تنسيقات (بناءً على كود الأخ مختار بدون الإطلاع على الملف) جرب الكود التالي .. (لم أجربه) Sub mokhtest() ActiveCell.Copy Sheets("مستودع").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues End Sub

جرب الكود التالي رغم أنني كنت أفضل العمل على الملف الأصلي للإطلاع عليه بشكل أدق تم تجاهل الأوراق المخفية حتى لا يحدث خطأ بالكود إذا وجدت أوراق عمل مخفية الملف المرفق في المشاركة الأولى بها أوراق عمل مخفية !!! Sub YasserKhalil() Dim SH As Worksheet For Each SH In ActiveWorkbook.Worksheets With SH If .Visible = False Then GoTo 1 If WorksheetFunction.CountIf(.Range("G6:G36"), ">0") > 0 Then .PrintPreview End If End With 1 Next SH MsgBox "OK" End Sub

هل كل أوراق العمل سيتم العمل عليها أم أن هناك أوراق عمل سيتم تجاهلها؟ سؤال آخر : هل هناك أوراق عمل مخفية تريد أن ينطبق عليها الكود أم لا ؟؟ الملف غير معبر عن الطلب وهذا سيسبب أن يكون هناك لغط كثير بالموضوع ..أفضل في مثل تلك الموضوعات إرفاق الملف الأصلي ..يمكنك مسح البيانات الحساسة في الملف الأصلي ثم إرفاقه