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

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

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

أخي الكريم محمود أبو سيف يرجى تغيير اسم الظهور للغة العربية (وهذا ليس أول نداء لك لتغيير اسم الظهور) إليك الملف التالي عله يفي ببعض من طلبك .. البضاعة.rar

اسكت بلاش موضوع الفاكهة ده لأني فعلا بقيت بطيخة من كتر القعدة

أخي الغالي رجب دا عشمي فيك والله .. إن شاء الله ناوي أزورك مش عشان البط ..يكفيني كوباية عثير وثاندوتث كبده .. أنا قنوع ومش عايز أتقل عليك

أخي العزيز طارق الحمد لله أن تم المطلوب على خير .. أفضل كلمة "جزاكم الله خيراً" أكثر من كلمة الشكر ، فلكلمة "جزاكم الله خيراً" وقع في نفسي أفضل بكثير من شكراً تقبل تحياتي

أخي الكريم أحمد لقد سبقني المعلم الكبير رجب بالحل .. ولكن بالفعل أن كنت مجهز حل من بدري لكن كان ينقصني فقط كلمة السر لإضافتها للكود .. عموماً الحل قريب جداً من الحل المقدم من أخونا الغالي رجب ..فقط اختلاف بسيط ، وإليك الكود إثراءً للموضوع لا أكثر Sub CreateSheets() Dim Cel As Range, strCel As String Application.ScreenUpdating = False ThisWorkbook.Unprotect 123 Sheet2.Unprotect 123 For Each Cel In Sheet1.Range("D4:R" & Sheet1.Cells(Rows.Count, 4).End(xlUp).Row) strCel = Trim(Cel.Value) If strCel <> "" Then If Not Evaluate("ISREF('" & strCel & "'!A1)") Then Sheet2.Copy After:=Sheets(Sheets.Count) ActiveSheet.Name = strCel Cel.Hyperlinks.Add Cel, "", , "Screen_Tip", strCel Cel.Hyperlinks(1).SubAddress = "'" & strCel & "'" & "!A1" ActiveSheet.Protect 123 End If End If Next Cel ThisWorkbook.Protect 123 Sheet2.Protect 123 Application.ScreenUpdating = True MsgBox "Done ...", 64 End Sub تقبل تحياتي Create Sheets By Cells In Range & Add Hyperlinks YasserKhalil.rar

الأخ الكريم عبد الله صقر أهلاً بك في المنتدى ونورت بين إخوانك يرجى تغيير اسم الظهور للغة العربية تقبل تحياتي

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

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

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

أخي الكريم طارق صراحة الموضوع معقد بعض الشيء لكن بفضل الله وحده تمكنت من الوصول لسبب المشكلة وهو الإجراء الفرعي في حدث الفورم اخذف الإجراء الموجود واستبدل التالي مكانه Sub ListArr(Cmd As String) Dim sTe As String: sTe = Me(Cmd).Text Dim II As Long, E As Long E = 0 For II = LBound(Arr1) To UBound(Arr1) If CStr(Arr1(II)) <> sTe And Not IsEmpty(Arr1(II)) Then E = E + 1: ReDim Preserve Arr2(E - 1) Arr2(E - 1) = Arr1(II) End If Next II ReDim Arr1(E): Arr1 = Arr2 End Sub تقبل تحياتي

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

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

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

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

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

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

أخي الحبيب سعيد بصراحة الكود الذي تريد التعديل عليه كود معقد بعض الشيء وبطيء كما قلت ولا أدري ما الداعي لهذا التعقيد .. حاولت تتبع أسطر الكود لأعرف ما هي المهمة التي يقوم بها (تعبتني وكان من الأفضل شرح المطلوب من الكود بدلاً من أن تعطيني كود وتقوله عدله ، فالتعديل في بعض الأحيان يكون أصعب من كتابة الكود نفسه خصوصاً إذا لم أكن من كتبت أسطر الكود) المهم قمت بعمل حيلة أعجبتني أنا شخصياً ..اعتمد على العمود C في ورقة الفواتير الصادرة وقمت بإخفاء الخلايا الفارغة والتي لا تريد ترحيلها ..وفي السطر التالي قمت بنسخ الخلايا الظاهرة فقط مما جعل الكود أسرع من كودك الأول بكثير ويؤدي الغرض أيضاً .. إليك الكود الجديد للطلب الثاني Sub TarhilModified() Dim Ws As Worksheet, Sh As Worksheet, LR As Long Set Ws = Sheet4: Set Sh = Sheet5 Application.ScreenUpdating = False Application.Calculation = xlManual LR = Sh.Cells(Rows.Count, "L").End(xlUp).Row + 1 With Ws .Range("C8:C" & .Cells(Rows.Count, "C").End(xlUp).Row + 1).SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True .Range("C8:C" & .Cells(Rows.Count, "C").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy Sh.Range("L" & LR).PasteSpecial xlPasteValues .Range("I8:J" & .Cells(Rows.Count, "C").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy Sh.Range("M" & LR).PasteSpecial xlPasteValues .Cells.EntireRow.Hidden = False Sh.Range("I" & LR).Resize(1, 3).Value = Array(Ws.Range("M4").Value, Ws.Range("M2").Value, Ws.Range("B4").Value) Sh.Activate End With Application.CutCopyMode = False Application.Calculation = xlAutomatic Application.ScreenUpdating = True End Sub تقبل تحياتي

أخي الغالي سعيد بيرم إليك الطلب الأول .. عله يون المطلوب وبارك الله فيك على التوضيح المفصل والذي يزيل أي لبس Sub TransferData() Dim Ws As Worksheet, Sh As Worksheet, LR As Long Set Ws = Sheet2: Set Sh = Sheet5 Application.ScreenUpdating = False Ws.Range("B8:C" & Ws.Cells(Rows.Count, "B").End(xlUp).Row).Copy LR = Sh.Cells(Rows.Count, "Q").End(xlUp).Row + 1 Sh.Range("Q" & LR).PasteSpecial xlPasteValues Sh.Range("P" & LR).Value = Ws.Range("B6").Value Application.CutCopyMode = False Application.ScreenUpdating = True End Sub تقبل تحياتي

أخي الكريم جرب التعديل التالي Sub CreateNewSheet() Dim Ws As Worksheet, Sh As Worksheet, Str As String, Y As Integer, X Set Sh = Sheet1 For Each Ws In ThisWorkbook.Worksheets Str = Ws.Range("D3").Formula X = Val(Mid(Str, 2, InStr(Str, "&") - 1)) If Y > X Then Y = Y Else Y = X Next Ws Sh.Copy After:=Sheets(Sheets.Count) With ActiveSheet .Name = "نقد " & Y + 1 .Range("D3").Formula = Replace(.Range("D3").Formula, Val(Mid(.Range("D3").Formula, 2, InStr(.Range("D3").Formula, "&") - 1)), Y + 1) End With Sh.Activate: Sh.Range("A1").Select End Sub فاتورة 2016.rar

أخي الكريم يوضع الكود في موديول جديد .. لتنفيذ الكود اضغط Alt + F8 من لوحة الفاتيح واختار اسم الماكرو CreateNewSheet .. يمكنك معرفة البدايات من خلال الرابط التالي بداية الطريق لإنقاذ الغريق

أخي الحبيب سليم بارك الله فيك على هذا التميز والإبداع بالنسبة للكود خاصتك اعتمدت على عدد أوراق العمل في القيمة الجديدة أي إنك اعتمدت على Sheets.Count .. وبالنسبة لأخونا أبو عبد الله طلب البحث عن أكبر قيمة في الخلية D3 أولاً ثم القيمة الجديدة تعتمد على أكبر قيمة مضافاً إليها واحد ..

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

أخي الكريم بو عبد الله جرب الكود التالي عله يفي بالغرض Sub CreateNewSheet() Dim Ws As Worksheet, Y As Integer, X For Each Ws In ThisWorkbook.Worksheets X = Val(Mid(Ws.Range("D3").Formula, 2, 1)) If Y > X Then Y = Y Else Y = X Next Ws Sheets("نقد").Copy After:=Sheets(Sheets.Count) ActiveSheet.Range("D3").Formula = Replace(ActiveSheet.Range("D3").Formula, Val(Mid(ActiveSheet.Range("D3").Formula, 2, 1)), Y + 1) End Sub تقبل تحياتي