hicham2610

السلام عليكم بالنسبة للكود التالي: Range("I7:I150").Select Application.CutCopyMode = False Selection.Copy Windows("prog.xlsm").Activate Range("P9").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False كيف أعدل ليصل إلى آخر سطر فيه بيانات هل فقط ب Range("I7:I7").Select Application.CutCopyMode = False Selection.Copy Windows("prog.xlsm").Activate Range("P9").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False أم من الأفضل وضع مثلا5000 Range("I7:I5000").Select Application.CutCopyMode = False Selection.Copy Windows("prog.xlsm").Activate Range("P9").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False وجزاكم الله خيرا

جزاك الله خيرا أخي الكريم ملف prog فيه زر يشتغل على الملفين المرفقين CT و AO لكن بهذه الوضعية أريد أن يتجاوز عدد الأسطر بحيث ذاتيا يشتغل على ملفات أخرى مهما كان عدد السطر المملوءة فيها وأن لايتوقف في السطر 78 أو 150 بحيث يصبح صالحا للاشتغال على ملفات أخرى ويكون المحدد هو الذهاب لغاية آخر سطر فيه بيانات وجزاكم الله خيرا بالنسبة لاختصار الكود توصلت ب:الكود في المرفقات Sub Macro1() Dim F As FileDialog Dim Doc1 As String, Doc2 As String Dim WB1 As Workbook, WB1SH As Worksheet Dim WB2 As Workbook, WB2SH As Worksheet, WB2Nom Dim WB3 As Workbook, WB3SH As Worksheet, WB3Nom Set WB1 = ThisWorkbook Set WB1SH = WB1.Worksheets("Feuil2") MsgBox "Merci d'ouvrir le fichier C.T AO", vbInformation, "HICHAM" Set F = Application.FileDialog(msoFileDialogOpen) With F F.Title = "Merci d'ouvrir le fichier C.T AO" .AllowMultiSelect = False .Filters.Add "Fichiers Excel", "*.xlsx", 1 .Show On Error Resume Next F.Execute If Err <> 0 Then Err.Clear Exit Sub End If On Error GoTo 0 Set WB2 = ActiveWorkbook End With UserForm1.Show Set WB2SH = ActiveSheet MsgBox "Merci d'ouvrir le fichier AO", vbInformation, "HICHAM" Set F = Application.FileDialog(msoFileDialogOpen) With F F.Title = "Merci d'ouvrir le fichier AO" .AllowMultiSelect = False .Filters.Add "Fichiers Excel", "*.xlsx", 1 .Show On Error Resume Next F.Execute If Err <> 0 Then Err.Clear Exit Sub End If On Error GoTo 0 Set WB3 = ActiveWorkbook End With UserForm1.Show Set WB3SH = ActiveSheet WB3SH.Cells.Copy WB1SH.Range("A1") WB1.Worksheets("Feuil2").Rows("9:150").RowHeight = 15 WB2SH.Range("F7:F150").Copy WB1SH.Range("G9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False WB2SH.Range("G7:G150").Copy WB1SH.Range("J9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False WB2SH.Range("H7:H150").Copy WB1SH.Range("M9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False WB2SH.Range("I7:I150").Copy WB1SH.Range("P9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False WB2SH.Range("J7:J150").Copy WB1SH.Range("S9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False WB2SH.Range("K7:K150").Copy WB1SH.Range("V9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False WB2SH.Range("L7:L150").Copy WB1SH.Range("Y9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False WB2SH.Range("M7:M150").Copy WB1SH.Range("AB9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False WB1SH.Range("I9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-3]*RC[-1],"""")" WB1SH.Range("I9").AutoFill Destination:=WB1SH.Range("I9:I78"), Type:=xlFillDefault WB1SH.Range("I9:I78").Select WB1SH.Range("I9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-3]*RC[-1],"""")" WB1SH.Range("L9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-6]*RC[-1],"""")" WB1SH.Range("L9").AutoFill Destination:=WB1SH.Range("L9:L78"), Type:=xlFillDefault WB1SH.Range("L9:L78").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-6]*RC[-1],"""")" WB1SH.Range("O9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-9]*RC[-1],"""")" WB1SH.Range("O9").AutoFill Destination:=WB1SH.Range("O9:O78"), Type:=xlFillDefault WB1SH.Range("O9:O78").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-9]*RC[-1],"""")" WB1SH.Range("R9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-12]*RC,"""")" WB1SH.Range("R9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-12]*RC,"""")" WB1SH.Range("R9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-12]*RC[-1],"""")" WB1SH.Range("R9").AutoFill Destination:=Range("R9:R78"), Type:=xlFillDefault WB1SH.Range("U9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-15]*RC[-1],"""")" WB1SH.Range("U9").AutoFill Destination:=Range("U9:U78"), Type:=xlFillDefault WB1SH.Range("X9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-18]*RC[-1],"""")" WB1SH.Range("X9").AutoFill Destination:=Range("X9:X78"), Type:=xlFillDefault WB1SH.Range("AA9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-21]*RC[-1],"""")" WB1SH.Range("AA9").AutoFill Destination:=Range("AA9:AA78"), Type:=xlFillDefault WB1SH.Range("AD9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-24]*RC[-1],"""")" WB1SH.Range("AD9").AutoFill Destination:=Range("AD9:AD78"), Type:=xlFillDefault End Sub

السلام عليكم توصلت لإنجاز هذا البرنامج عبر تسجيل الماكرو فهو ينسخ ورقة بكاملها وينسخ أعمدة نوع الطلبات ويجري المجاميع بشرط معين والتي لاتحقق ذلك الشرط يتركها فارغة طريقة الاشتغال:يفتح AO و CT و prog والضغط على الزر في الورقة الأولى من prog المرجو من الإخوة الكرام التعديل على الكود الموجود في الزر لكي يكون مختصرا والأهم: ليشمل آخر سطر فيه بيانات لكي يكون صالحا مستقبلا لإشتغال على اي ملفات اخرى غير هذه وشكرا جزيلا من فضلك لا تكرر نفس المشاركات والا ستحذف جميع المشاركات 2.rar

وعليكم السلام أخي الكريم شكرا لاهتمامك ، لكن لم يناسب وضعيتي شكرا مرة أخرى

السلام عليكم أعيد صياغة السؤال وأبسطه لعلني أجد عند الإخوة الأفاضل جوابا عندي ملفان الملف الأول باسم CT وفي الورقة الأولى فيه وتتم الإشارة للمنتوج المطابق في عمود الشركة المعنية ب :C وملف آخر باسم AO وفي الورقة الأولى فيه يتم حساب المجاميع حسب المنتوج والشركة هاذين الملفان يوضعان في ملف أصفر مثلا على سطح المكتب المطلوب الإخوة الكرام ملف إكسيل ثالث به ماكرو يقوم الماكرو بفتح AO ويقوم بجعل خانات المجاميع فارغة في الورقة الأولى للتي ليس لها في الورقة الأولى "C" في الملف CT ، ويذهب لغاية 100 سطر. وجزاكم الله خيرا الملف.rar

السلام عليكم عندي ملفان الملف الأول باسم CT وفي الورقة الأولى فيه وتتم الإشارة للمنتوج المطابق في عمود الشركة المعنية ب :C وملف آخر باسم AO وفي الورقة الأولى فيه يتم حساب المجاميع حسب المنتوج والشركة هاذين الملفان يوضعان في ملف أصفر مثلا على سطح المكتب المطلوب الإخوة الكرام ملف إكسيل ثالث به ماكرو بحيث عند فتحه مثلا تظهر نافذة الترحيب مثل: هشام السلام عليكم ، المرجو اختيار الملف المعني يقوم بعد ذلك المستعمل بتحديد الملف المعني فيقوم البرنامج الماكرو بفتح AO ويحسب المجاميع في الورقة الأولى ، فقط للتي هي مطابقة( باعتماد ملف CT ) والمشار إليها ب C لكل شركة والتي فيها غير C يترك المجموع الخاص بها فارغاويذهب لغاية 100 سطر مثلا الإخوة الكرام هل من اقتراحات ؟ وشكرا جزيلا وجزاكم الله خيرا الملف.rar

آمين وأنتم من أهل الجزاء

الملف: انقر هنا وهذا رابط اخر للملف MediaFire

الجزء:6 والأخير الملف.rar

الجزء:5

الجزء:4

آمين ولك بالمثل وزيادة الجزء:3

الجزء:2 https://www.youtube.com/watch?v=jhZ-dU63KVs

الجزء:1

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

جزاك الله خيرا وأحسن إليك

السلام عليكم من فضلكم أحتاج تقييم الأساتذة والأعضاء الكرام أنجزت هذه المسابقة على إكسيل يمكن أن يتنافس فيها أكثر من لاعب بمقارنة نقطهم المحصل عليها يمكن بدء المرحلة بالضغط على NOUVEAU وبذلك تقترح المرحلة البحث عن 10 أجوبة لكل جواب نقطة واحدة وتخصم ربع نقطة عن كل خطإ يمسك حرف واحد في الإطار الذي تحت"أكتب أسفله" وهو المكان المسموح الكتابة فيه وإن وجد الحرف في الكلمة سيكتب في المكان المخصص له من الجواب وفي حالة إتمام الجواب الانتظار ثانيتين لتنتقل اللعبة للسؤال الموالي، بعد مسك الحرف الضغط على Proposer لمسك الاقتراح في الملف شرح مختصر للعبة أترككم لاكتشافها وتقييمها والسلام عليكم Mossabaqa.rar

السلام عليكم تفضل: 1-يمكنك نسخها من هنا: ٱ ٱ 2- عبر إدراج من الوورد ثم رموز والبحث هناك خاصة نوع الخط:أندلسي 3- عبر موقع لوحة مفاتيح عربيةhttps://www.lexilogos.com/clavier/araby.htm

السلام عليكم من فضلكم هذه لعبة تعتمد على تخمين الكلمة التي ستظهر في الخلية J7 (مؤقتا سأخفيها لاحقا لكي لاتظهر للمستعمل) يكون مسك حروف الكلمة حرفا واحدا بعد الآخر في E11 ثم بالضغط على زر Proposer وفي كل مرحلة 10 كلمات وجب اكتشافها وفي حالة الخطأ تبدأ صورة الشنق في التركيب وعدد الأخطاء المسموح بها في كل كلمة 4 فقط وبعد انتهاء المحاولات تخصم ربع نقطة عن كل خطأ ويتم الانتقال للكلمة الموالية آليا بعد انتظار ثانتين تقريبا ولايتم الضغط على زر جديد nouveau إلا بعد انتهاء المرحلة المكونة من 10 كلمات المشكلة في البحث العشوائي عن الكلمة الموالية في Proposer أريد أن لا يعيد الكلمة فيJ7 وأن تكون الكلمات متغيرة ومختلفة وجزاكم الله خيرا jeu-du-pendu V3-1.xlsm

العفو أحي الفاضل بالتوفيق إن شاء الله

السلام عليكم عمل رائع بارك الله فيك لوتكرمت ممكن شرح لهذا الأمر، جزاك الله خيرا

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

السلام عليكم من الأفضل إرفاق ملف أو ملف مشابه به معلومات وهمية وبه المشكلة أعتقد أن: السبب الرقم السري الذي وضعت جرب حذفه في أول الكود وإرجاعه في آخر الكود كمايلى: ()Sub HICHAM ActiveSheet.Unprotect "passe" 'passe هو الرقم السري الدذي وضعت ' ' الكود هنا ' 'ارجاع الرقم السري في نهاية الكود ActiveSheet.Protect "passe" End Sub بالتوفيق إن شاء الله

السلام عليكم تفضل هذه المحاولة بالمعادلات ، أتمنى أن تفي بالغرض والسلام عليكم المجموع العام ن1.xlsm

السلام عليكم المرجو من ذوي الخبرة تفسير هذا الكود بالتفصيل Option Explicit Dim tablo, tabloR() Dim i&, iR&, j& Sub SupprimerLesVides() tablo = Range("X10:AP48") ReDim tabloR(1 To UBound(tablo, 1), 1 To UBound(tablo, 2)) For j = 1 To UBound(tablo, 2) If j <> 5 And j <> 10 And j <> 15 Then iR = 1 For i = 1 To UBound(tablo, 1) If tablo(i, j) <> "" Then tabloR(iR, j) = tablo(i, j) iR = iR + 1 End If Next i End If Next j Range("X10:AP48").ClearContents Range("X10").Resize(UBound(tabloR, 1), UBound(tabloR, 2)) = tabloR End Sub وجزاكم الله خيرا