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

أخي الكريم حماده سعد الله جرب الكود التالي عله يفي بالغرض Sub ExportActiveSheet() Dim WB As Workbook, WS As Worksheet Set WS = ActiveSheet Application.DisplayAlerts = False If WB Is Nothing Then WS.Copy ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value Set WB = ActiveWorkbook If Dir(ThisWorkbook.Path & "\ExportedWB.xlsx") <> "" Then MsgBox "Workbook 'ExportedWB' Is Already Existing", vbCritical WB.Close False Else WB.SaveAs Filename:=ThisWorkbook.Path & "\ExportedWB.xlsx" WB.Close True MsgBox "Workbook Exported In The Same Path ...", 64 End If End If Set WS = Nothing Set WB = Nothing Application.DisplayAlerts = True End Sub تقبل تحياتي

أخي الكريم سعيد بيرم يبدو أننا لم نصل لاتفاق بعد في موضوع توضيح المطلوب .. الأكواد ليست أسطر أحفظها ..ربما أكتب كود وبعد ربع ساعة أنسى الأسطر التي كتبتها وهذا أمر طبيعي ربما معي ، عندما أشرع بكتابة الكود أبدأ بسطر سطر ثم أقوم بفحص الأسطر التي كتبت وهكذا إلى أن تكتمل الفكرة والكود وأفحص الكود أكثر من مرة ، ولكل ملف ولكل ورقة عمل طبيعة خاصة تختلف بشكل دائم .. فمع إضافة أعمدة جديدة كما فعلت كان لابد من مراجعة الكود من جديد سطر بسطر ، وما زاد الموضوع تعقيد أنك تريد دمج كودين وكل كود فيه متغيرات معرفة مشابهة للكود الآخر مما اضطرني إلى تغيير المتغيرات كلها من جديد ليعمل الكود بسلاسة ، وصدقني إذا قلت لك أن التعديل على الكود أصعب من كتابته من جديد عموماً جرب الكود التالي عله يفي بالغرض Sub TransferMatchingData() Dim Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet Dim Cel As Range, Found As Range Dim LR As Long, LastRow As Long Dim X As Long, I As Long Set Ws1 = Sheet1: Set Ws2 = Sheet2: Set Ws3 = Sheet3 Application.ScreenUpdating = False On Error Resume Next LR = Ws1.Cells(Rows.Count, 1).End(xlUp).Row LastRow = Ws3.Cells(Rows.Count, "E").End(xlUp).Row + 1 For Each Cel In Ws1.Range("B8:B" & LR) Set Found = Ws2.Range("B:B").Find(What:=Cel.Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) If Not Found Is Nothing And Not IsEmpty(Cel.Value) Then Found.Offset(, 1).Value = Cel.Offset(, 1).Value Found.Offset(, 4).Value = Cel.Offset(, 4).Value End If Next Cel With Ws1 .AutoFilterMode = False .Range("A7:D7").AutoFilter Field:=3, Criteria1:="<>" & "" .Range("B8:C" & LR).SpecialCells(xlCellTypeVisible).Copy Ws3.Cells(LastRow, "E").PasteSpecial xlPasteValues .Range("F8:F" & LR).SpecialCells(xlCellTypeVisible).Copy Ws3.Cells(LastRow, "G").PasteSpecial xlPasteValues Ws3.Cells(LastRow, "B").Value = Ws1.Range("B6").Value Ws3.Cells(LastRow, "D").Value = Ws1.Range("F6").Value Ws3.Cells(LastRow, "C").Value = Ws1.Range("C3").Value .AutoFilterMode = False End With Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "Done...", vbInformation, "YasserKhalil" End Sub تقبل تحياتي

أخي الكريم يفضل إرفاق ملف معبر عن الملف الأصلي للعمل عليه ... وإن شاء الله إذا تيسر لي الأمر والوقت سأقوم بشرح الكود رغم أنه لن ينفع الشرح إلا إذا كان المتعلم مريد للتعلم وإذا كان هناك إلمام كافي بالأساسيات .. بالنسبة إذا كانت القيم المفردة في شيت آخر سيتم فقط الإشارة إلى اسم ورقة العمل في الكود قبل هذا الجزء Cells(lRow, "M").Value فلو كانت الورقة اسمها Sheet2 سيكون السطر بهذا الشكل Sheets("Sheet2").Cells(lRow, "M").Value اما بالنسبة للتراجع عن الكود فهذا أمر غير يسير ويحتاج لأكواد أخرى وأنا لا أحبذ ذلك إنما يمكن مسح النطاق الذي يحتوي على الخلايا المدمجة بالإشارة إلى النطاق ثم استخدام ClearContents لتنفيذ المطلوب

أخي الكريم كمال هل أنت متأكد من عمل الكود الذي قمت بإرفاقه لأن الكود المرفق يقوم بعمل حلقة تكرارية لملفات تختارها ثم يقوم بنسخ نطاق محدد عموماً جرب الكود التالي سيتم تنفيذه بمجرد فتح الملف الرئيسي س .. Sub SUM_WBs() Dim WBK As Workbook Dim FolderPath As String Dim FileName As String Dim Counter As Double FolderPath = ThisWorkbook.Path & "\" FileName = Dir(FolderPath & "*.xl*") Application.ScreenUpdating = False Application.Calculation = xlManual Do While FileName <> "" If FileName <> ThisWorkbook.Name Then Set WBK = Workbooks.Open(FolderPath & FileName) Counter = Counter + WBK.Sheets("Sheet1").Range("A1").Value WBK.Close SaveChanges:=False End If FileName = Dir() Loop ThisWorkbook.Sheets("Sheet1").Range("A1").Value = Counter Application.Calculation = xlAutomatic Application.ScreenUpdating = True End Sub وإليك الملف المرفق Loop Through Closed Workbooks To Sum Specific Cell YasserKhalil.rar

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

أخي الكريم الشيباني يرجى تغيير الرقم 1 في اسم الظهور ليعبر عن لقبك وعن شخصكم الكريم جرب الكود التالي لتحويل الخلايا التي تحتوي على معادلات إلى قيم ... رغم أنك أربكتني حيث أن عنوان الموضوع "تحويل المعادلات إلى قيم" واسم الملف المرفق "تحويل معادلات إلى قيم" والشرح داخل الملف المرفق "تحويل المعادلات إلى قيم" ، أما في شرح المطلوب في الموضوع ذكرت العكس أنك تريد إعادة تحويل القيم إلى معادلات .. عموماً جرب السطر التالي من الكود Sub ConvertFormulasToValues() Range("A6").CurrentRegion.SpecialCells(xlCellTypeFormulas).Value = Range("A6").CurrentRegion.SpecialCells(xlCellTypeFormulas).Value End Sub تقبل تحياتي

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

أخي الكريم كمال أهلاً بك في المنتدى ونورت المنتدى يرجى وضع ملفاتك أو نماذج منها في مجلد ثم ضغطه ورفعه ليسهل العمل على المطلوب .. وهل كل الملفات ستكون في مجلد واحد مع المجلد الرئيسي س الذي يعتبر تجميع للملفات الأخرى ... تقبل تحياتي

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

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

تشرفنا بيك أستاذنا الفاضل ذكي جمعه وأهلاً بيك في أسرة أوفيسنا تقبل تحياتي

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

أخي الكريم أين الملف المرفق ليطلع عليه الأعضاء؟ ورجاءً تغيير اسم الظهور ليعبر عن شخصكم الكريم أيها الأخ الفاضل المسلم العربي

أخي الكريم مختار الأرقام في الكود التالي عبارة عن أول خلية مفردة بعد الخلايا المدمجة (والتي عددها 30 خلية : هي 10 خلايا مدمجة * كل خلية مدمجة = 3 خلايا مفردة) لاحظت أن نتائج الكود عبارة عن 7 و 17 و 27 ... فقمت بعمل السطر في الكود السابق بناءً على ذلك بأن قيمة المتغير I تزيد 10 إذا كان أول رقم في الناتج من ناحية اليمين يساوي 7 .. Sub Test() MsgBox 37 Mod 30 MsgBox 77 Mod 30 MsgBox 117 Mod 30 MsgBox 157 Mod 30 MsgBox 197 Mod 30 End Sub لو عندك فكرة تانية أرحب بها لأن الفكرة جات كدا معايا مش مدروسة مجرد خيالات بعض الإبداع تقبل تحياتي

تفضل أخي الكريم Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 1 And Target.Row > 1 And Target.Row < 5001 And Target.Value = "ف" Then Application.EnableEvents = False With Target Target.Value = Time Target.NumberFormat = "hh:mm:ss" Columns(Target.Column).EntireColumn.AutoFit End With Application.EnableEvents = True End If End Sub

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

جرب الكود بهذا الشكل (لم أختبر الكود) فقط قمت بإضافة نقطة قبل كلمة Cells للإشارة إلى ورقة العمل التي سيكون عليها الدور في الحلقة التكرارية دون تنشيط الورقة Sub DelAllData() Dim Ws As Worksheet Application.ScreenUpdating = False For Each Ws In ThisWorkbook.Worksheets With Ws .Range(.Cells(4, "A"), .Cells(Rows.Count, "J")).ClearContents End With Next Ws Sheets("Data").Activate Application.ScreenUpdating = True End Sub

أخي الكريم نور وحيد الكود يعمل لدي وعندي أوفيس 2013 وويندوز 10 .. هل تقوم بتنفيذ الكود وأنت منشط الورقة الأولى التي تحتوي على زر الترحيل؟ ما هو الخطأ الذي يظهر معك .. قم بالنقر على كلمة Debug عند ظهور رسالة الخطأ وانسخ السطر باللون الأصفر لمعرفة الخطأ ..

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

أخي الكريم إليك الكود التالي عله يفي بالغرض Sub LoopMergedCells() Dim I As Long, lRow As Integer lRow = 1 For I = 7 To 236 Step 3 If I <> 7 And Right(I Mod 30, 1) = "7" Then I = I + 10 Cells(I, 1).Value = Cells(lRow, "M").Value lRow = lRow + 1 Next I End Sub وإليك ملف مرفق مطبق فيه الكود تقبل تحياتي Loop Through Merged Cells & Transfer Data From Unmerged Cells YasserKhalil.rar

أخي الحبيب مختار ليه السطر ده .. .Activate أطن فهمتني ..

أخي الكريم هذا ملف آخر يمكنك من اختيار الملف الذي تريد فتحه ... Open Excel File Using File Dialog On UserForm.rar

جرب المعادلة بهذا الشكل =IF(AND($E$1<>"",BL9<>"",BL9>$E$1),MOD(BL9-$E$1,1),0) ويرجى عند طرح موضوع أن يكون هناك مقدمة وشرح للمطلوب قبل إرفاق الملف ... لا ترفق الملف وفقط (دا حتى مفيش السلام عليكم) تقبل تحياتي

أخي الكريم أين الملف المرفق ...؟

أخي الكريم أهلاً بك في المنتدى ولا مانع من قراءة التوجيهات طالما أصبحت عضواً في المنتدى فالتوجيهات ستساعدك على طرح الموضوعات والتعامل مع المنتدى بشكل أفضل جرب الملف التالي عله يكون المطلوب Open Excel File Using UserForm.rar