رجب جاويش

أخى الحبيب / محمود الشريف جزاك الله كل خير على هذه الكلمات الطيبة

أخى الحبيب / محمود الشريف جزاك الله كل خير على هذه الكلمات الطيبة

السلام عليكم وبعد إذن أخى الحبيب / أبو سما أخى الفاضل / محمد ما رأيك فى هذا الكود بدلا من الكود الموجود بالملف حيث يقوم الكود التالى بالترحيل حتى ولو لم تكن الصفحات التى سوف يرحيل إليها موجود فى البداية كما أنه يرحل البيانات بنفس التنسيقات وعمل مسلسل فى الصفحات التى سوف يرحل إليها Sub ragab() Dim cl As Range, sh As Worksheet Application.ScreenUpdating = False For Each sh In ThisWorkbook.Worksheets If Not sh.Name = "Sheet1" Then sh.Range("A2:L1000").ClearContents End If Next LR = Cells(Rows.Count, 1).End(xlUp).Row For Each cl In Range("L2:L" & LR) x = Trim(cl.Value) On Error Resume Next If Worksheets(x) Is Nothing Then Sheets.Add.Name = x Sheets(x).Move After:=Sheets(Sheets.Count) End If Sheets("sheet1").Range("A1:L1").Copy Sheets(x).Range("A1").PasteSpecial xlPasteValues Sheets(x).Range("A1").PasteSpecial xlPasteFormats cl.Offset(0, -11).Resize(1, 12).Copy Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial xlPasteValues Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row, 1).PasteSpecial xlPasteFormats Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row, 1).PasteSpecial xlPasteColumnWidths Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 3).End(xlUp).Row, 1) = Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 3).End(xlUp).Row, 1).Row - 1 Application.CutCopyMode = False Next MsgBox "تم الترحيل بنجاح الى صفحات منفصلة" Sheets("sheet1").Select Application.ScreenUpdating = False End Sub

السلام عليكم ورحمة الله وبركاته كل الشكر لأخى الفاضل / شوقى ربيع على هذا الإبداع ولإثراء الموضوع وكما طلب أخى الحبيب / محمود الشريف كود لإنشاء الصفحات إن لم تكن موجودة مع بعض الإضافات الأخرى مثل الترحيل بنفس التنسيقات وعمل مسلسل فى الصفحات المرحل اليها Sub ragab() Dim cl As Range, sh As Worksheet Application.ScreenUpdating = False For Each sh In ThisWorkbook.Worksheets If Not sh.Name = "Sheet1" Then sh.Range("A2:L1000").ClearContents End If Next LR = Cells(Rows.Count, 1).End(xlUp).Row For Each cl In Range("L2:L" & LR) x = Trim(cl.Value) On Error Resume Next If Worksheets(x) Is Nothing Then Sheets.Add.Name = x Sheets(x).Move After:=Sheets(Sheets.Count) End If Sheets("sheet1").Range("A1:L1").Copy Sheets(x).Range("A1").PasteSpecial xlPasteValues Sheets(x).Range("A1").PasteSpecial xlPasteFormats cl.Offset(0, -11).Resize(1, 12).Copy Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial xlPasteValues Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row, 1).PasteSpecial xlPasteFormats Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row, 1).PasteSpecial xlPasteColumnWidths Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 3).End(xlUp).Row, 1) = Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 3).End(xlUp).Row, 1).Row - 1 Application.CutCopyMode = False Next MsgBox "تم الترحيل بنجاح الى صفحات منفصلة" Sheets("sheet1").Select Application.ScreenUpdating = False End Sub قاعدة بيانات اعدادى2.rar

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

أخى الحبيب / محمد أبو البراء جزاك الله كل خير على هذا العمل القيم

اللهم رب الناس أذهب البأس اشفه أنت الشافي لا شفاء إلا شفاؤك. أسأل الله العظيم رب العرش العظيم أن تشفي أستاذنا الكبير عاجلاً غير آجل. اللهم ألبسه ثوب الصحة والعافية عاجلا غيرآجل ياأرحم الراحمين. آمين يارب العالمين.

أخى الفاضل جرب الكود أولا كما هو وأخبرنى هل يعمل أم لا

أخى الحبيب / أبو إيمان معادلة ممتازة تسلم ايديك

أخى الفاضل جرب هذه الطريقة لحذف كود معين داخل موديول Const Mod_Num = "Module2" Const Cod_Nam = "Test" Sub ragab() With ThisWorkbook.VBProject.VBComponents(Mod_Num).CodeModule .DeleteLines .ProcStartLine(Cod_Nam, 0), .ProcCountLines(Cod_Nam, 0) End With End Sub فى السطر الأول تحدد اسم الموديول الذى يحتوى على الكود Const Mod_Num = "Module2" فى السطر الثانى تحدد اسم الكود المراد حذفه Const Cod_Nam = "Test" وسوف تجد فى الملف المرفق مثال لذلك ملحوظة : لكى يعمل الكود بشكل سليم قم بعمل الأتى من محرر الأكواد اختار References من قائمة tools ثم ضع علامة صح أمام الإختيار Microsoft Visual Basic For Applications Extensibility حذف كود فقط.rar

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

أستاذى الفاضل / محمد يوسف تفضل آخر بالمعادلات مصنف3.rar

وعليكم السلام ورحمة الله وبركاته أستاذى الفاضل محمد تفضل ما تريد عن طريق كود Sub ragab() Application.ScreenUpdating = False [E2:R30].ClearContents For i = 2 To 30 MyArr = Trim(Cells(i, 4)) For Each cl In [E1:R1] x = UBound(Filter(Split(MyArr, ","), cl)) + 1 If x > 0 Then Cells(i, cl.Column) = cl Next Next Application.ScreenUpdating = True End Sub مصنف2.rar

أخى الفاضل الملف الذى أرفقته أنت يعمل معى بشكل سليم

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

أخى الحبيب / أبو إيمان جزاك الله كل خير

أخى الفاضل / أبو حنين الكود يعمل معى بشكل سليم

بعد إذن أخى الفاضل أبو عيد أخى الفاضل أبو حنين إليك طريقة حذف موديول عند تاريخ محدد وهى كما يأتى ضع هذا الكود فى حدث الـ WORKBOOK Const Dat = #5/31/2014# Const mod_num = 1 Private Sub Workbook_Open() On Error Resume Next If Date >= Dat Then With ActiveWorkbook.VBProject.VBComponents .Remove .Item("Module" & mod_num) End With End If End Sub ومن السطر الأول فى الكود حدد التاريخ الذى تريده Const Dat = #5/31/2014# ومن السطر الثانى حدد رقم الموديول الذى تريد حذفه Const mod_num = 1 حذف موديول.rar

أخى الحبيب / محمد أبو البراء جزاك الله كل خير على هذا المرور العطر والكلمات الطيبة

أخى الفاضل / عبد الله جزاك الله كل خير

أخى الفاضل يجب ضغط الملف أولا ببرنامج ضغط مثل WINRAR ثم رفعه

السلام عليكم كل الشكر لإخوتى المشاركين ولاثراء الموضوع تفضل أخى Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = [B2].Address Then If [B2] = "MMM" Then [C2] = [C2] + 1 End If End Sub المصنف1.rar

السلام عليكم بعد كل الشكر لإخوتى الأفاضل المشاركين هذا كود آخر لاثراء الموضوع Sub ragab() Dim i As Integer Dim LR As Integer Dim cl As Range Dim arr() As Variant '========================================= Set WF = Application.WorksheetFunction LR = Cells(Rows.Count, 2).End(xlUp).Row '========================================= For Each cl In Range("B7:B" & LR) If Not IsEmpty(cl) Then i = i + 1 ReDim Preserve arr(1 To i) arr(i) = cl End If Next Range("D7:D" & LR).ClearContents Range("D7").Resize(i) = WF.Transpose(arr) Erase arr End Sub

أخى الحبيب / سليم تسلم ايديك

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