رجب جاويش

كل عام وأنتم إلى الله أقرب وعلى طاعته أدوم

السلام عليكم ورحمة الله وبركاته يسعدنى المشاركة معكم فى هذا الموضوع الشيق أولا : فى حالة وجود الفراغات نستخدم هذا الكود Sub Transpose_RG() Dim i As Integer Dim LR As Integer Dim arr() As Variant '============================================================= [B1:B1000].ClearContents LR = Cells(Rows.Count, 1).End(xlUp).Row ReDim arr(1 To LR) '============================================================= For i = LR To 1 Step -1 arr(LR + 1 - i) = Cells(i, 1) Next [B1].Resize(LR) = Application.WorksheetFunction.Transpose(arr) End Sub وفى حالة اهمال الفراغات نستخدم الكود التالى Sub Transpose_RG() Dim i As Integer Dim ii As Integer Dim LR As Integer Dim arr() As Variant '============================================================= [B1:B1000].ClearContents LR = Cells(Rows.Count, 1).End(xlUp).Row '============================================================= For i = LR To 1 Step -1 If Not IsEmpty(Cells(i, 1)) Then ii = ii + 1 ReDim Preserve arr(1 To ii) arr(ii) = Cells(i, 1) End If Next [B1].Resize(ii) = Application.WorksheetFunction.Transpose(arr) End Sub Transpose.rar Transpose2.rar

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

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

أخى الفاضل مرحبا بك فى منتدى أوفيسنا يرجى تغير اسم الظهور الى اللغة العربية لسهولة التواصل كما أرجو الاعتياد على ارفاق ملف يوضح مثال لما تريد حتى تسهل على اخوانك بالمنتدى تقديم المساعدة المطلوبة بالنسبة لسؤالك ضع المعادلة التالية فى الخلية D2 =IF(B2="A";A2;0) واذا لم تحقق المطلوب يرجى ارفاق ملف يوضح المطلوب بدقة

السلام عليكم تفضل أخى Sub TARHIL() Dim Sh As String Dim i As Integer Dim AA As Integer '====================================================== Application.ScreenUpdating = False Sheets("ناجح").Range("A12:X1000").ClearContents Sheets("دور ثان").Range("A12:X1000").ClearContents Sheets("راسب").Range("A12:X1000").ClearContents '====================================================== For i = 12 To Cells(10000, "Y").End(xlUp).Row Sh = Cells(i, "Y").Value AA = Sheets(Sh).Cells(10000, 2).End(xlUp).Row + 1 If AA < 12 Then AA = 12 On Error Resume Next Range(Cells(i, "B"), Cells(i, "X")).Copy Sheets(Sh).Range("B" & AA).PasteSpecial xlPasteValues Application.CutCopyMode = False Sheets(Sh).Cells(AA, "A").Value = Sheets(Sh).Cells(AA, "A").Row - 11 Next i Application.ScreenUpdating = True MsgBox "تم الفصل بنجاح" End Sub الترحيل1.rar

السلام عليكم استخدم أخى هذه المعادلة =SUMIFS('1'!J2:J500;'1'!A2:A500;A2;'1'!B2:B500;B2;'1'!C2:C500;C2) JC LOG 2015.rar

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

أخى الحبيب ياسر هدية مقبولة تسلم ايديك

أخى الحبيب / ياسر خليل جزاك الله خيرا على هذا الموضوع القيم سر على بركة الله ونحن جميعا فى انتظار المزيد لنتعلم من ابداعاتكم تقبل تحياتى وتقديرى

أخى الفاضل / كمال محمد جزاك الله خيرا على كلماتك الطيبة ومرحبا بك فى عائلة أوفسينا والحمد أن تم المطلوب كما تريد

أخى الفاضل تسلم ايديك وجزاك الله خيرا

يا سلام على التواضع بجد أجمل تحياتى وتحيات بلشاى كلها

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

أخى الغالى : محمود الشريف تسلم ايديك هدية مقبولة جزاك الله كل خير

السلام عليكم أخى الحبيب ياسر أحسنت أخى الحبيب فكرتك أفضل بكتييييييييييير جدا طبعا تسلم ايديك

أخى الفاضل أرجو مزيد من التوضيح للمطلوب

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

السلام عليكم أفضل تحية لأخى الحبيب ياسر على فتح موضوعات تفيد الجميع وتفتح نقاشات جميلة تعود بالنفع على جميع الأعضاء بالنسبة لهذ الموضوع ( اخفاء جميع الأعمدة ما عدا أعمدة محددة ) الكود الذى قدمه أخى المبدع سليم هو أبسط كود يقوم بعمل المطلوب فعلا ولكن لاثراء الموضوع هذه فكرة أخرى وفيها يتم تحديد الأعمدة المراد عدم اخفاءها عن طريق الماوس داخل inputBox وفى حالة تحديد أعمدة غير متجاورة يستخدم مفتاح CTRL أثناء التحديد Sub ragab() Dim Rng As Range On Error Resume Next Application.DisplayAlerts = False Set Rng = Application.InputBox(Prompt:="قم بتحديد الأعمدة التى لا تريد اخفاءها عن طريق الماوس وعند اختيار أعمدة غير متجاورة اضغط مفتاح Ctrl أثناء التحديد", Title:="اخفاء مخصص", Type:=8) Application.DisplayAlerts = True If Rng Is Nothing Then Exit Sub Columns.Hidden = True Rng.EntireColumn.Hidden = False End Sub

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

السلام عليكم تفضل أخى Book123.rar

السلام عليكم تسلم ايديك أخى المبدع سليم واسمح لى بابداء بعض الملاحظات على الكود المسخدم أولا : السطر التالى i = .Range("A" & Rows.Count).End(xlUp).Row + 1 والخاص بتحديد أول سطر فارغ فى الصفحات المرحل اليها يعتمد على العمود A لايجاد أخر سطر به بيانات ثم يزيد عليه واحد لايجاد أول سطر فارغ وهذا ينتج عنه خطأ اذا كانت البيانات فى الصفحة الرئيسية لا تحتوى على بيانات فى العمود A مما يؤدى الى عدم ترحيل البيانات من الصفحة الرئيسية فى حالة أن تكون الخلية الموجودة فى العمود A فارغة كما يتضح من الصور التالية ولذلك يجب تعديل السطر السابق الى الصورة التالية لتلافى هذا الخطأ i = .UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1 ثانيا : يجب الوضع فى الاعتبار مسح البيانات القديمة فى الصفحات المرحل اليها قبل الترحيل لتجنب تكرار البيانات لذا يتم وضع هذا الجزء فى بداية الكود لمسح البيانات من الصفحات المرحل اليها قبل الترحيل For Each sh In ThisWorkbook.Worksheets If Not sh.Name = "MAIN_SHEET" Then sh.[A2:C1000].ClearContents End If Next مع خالص تحياتى وتقديرى لشخصكم الكريم writ_In_One Sheet1.rar

الحمد لله جزاك الله خيرا أخى الفاضل على هذا الدعاء الطيب

تفضل أخى أبو إلياس1.rar

السلام عليكم جرب أخى هذا الملف أبو إلياس1.rar