عبدالله باقشير

السلام عليكم تم التعديل في ثلاث اسطر اولا في كود اللصق Private Sub Kh_Start(iColumn As Integer) Dim RCount As Long, C As Integer 'C = Cells(iRow, Columns.Count).End(xlToLeft).Column + 1 C = Application.WorksheetFunction.CountA(Rows(iRow)) + 1 With MyRng RCount = .Cells(.Rows.Count, 1).End(xlUp).Row .Cells(1, iColumn).Resize(RCount, 1).Copy ' لصق عرض الاعمدة Cells(iRow, C).PasteSpecial xlPasteColumnWidths ' لصق الفورمات Cells(iRow, C).PasteSpecial xlPasteFormats ' لصق القيم Cells(iRow, C).PasteSpecial xlPasteValues Application.CutCopyMode = False End With End Sub ============================================================== تم تغيير السطر C = Cells(iRow, Columns.Count).End(xlToLeft).Column + 1 الى C = Application.WorksheetFunction.CountA(Rows(iRow)) + 1 السطر القديم كان يحسب آخر عمود ويضيف له القيمة واحد ولما يكون العمود الاول هو آخر عمود يحسب 1+1 ولكن السطر الجديد ولما يكون العمود الاول هو آخر عمود تكون قيمة المعادلة 0+1 وهو العمود الاول ============================================================== Private Sub kh_MyRngSet() With Sheets(Sh_Report) .Select .Range(Cells(iRow, 1), Cells(.Rows.Count, .Columns.Count)).Clear .PageSetup.PrintArea = "" End With With Sheets(Sh_MyDate) Set MyRng = .Range(MyRng_MyDate) End With Num = MyRng.Columns.Count End Sub =========================================================== تم تغيير السطر .Range(Cells(iRow, 2), Cells(.Rows.Count, .Columns.Count)).Clear الى .Range(Cells(iRow, 1), Cells(.Rows.Count, .Columns.Count)).Clear ليشمل مسح العمود الاول ايضا ============================================================================= Private Sub Kh_PageSetup() Dim LastRow As Long Dim LastColumn As Integer With Sheets(Sh_Report) LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row LastColumn = .Cells(iRow, Columns.Count).End(xlToLeft).Column With .PageSetup .PrintArea = Range("A1", Cells(LastRow, LastColumn)).Address .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = False End With End With End Sub تم تعديل السطر .PrintArea = Range("B1", Cells(LastRow, LastColumn)).Address الى .PrintArea = Range("A1", Cells(LastRow, LastColumn)).Address ليدخل العمود الاول في نطاق الطباعة ارجوا ان يكون الشرح مفهوما ملحوظة : تم اشعاري بالبريد بالرد على هذا الموضوع للاهمية الاخ الحبيب كيماس حفظه الله وتقبلوا تحياتي وشكري اعداد تقارير مدرسية.rar ثانيا في كود المسح ثالثا في كود تعيين الطباعة

السلام عليكم لاثراءالموضوع قمنا بعمل هذه الدالة للقيام بذلك Option Explicit ' بسم الله الرحمن الرحيم " '============================================" ' دالة خاصة لاحتساب الشهر 30 يوم " '============================================" 'Mydate: نص بالتاريخ الهجري " '============================================" 'Countday: عدد الايام " '============================================" '============================================" Function kh_MyTextHijri(Mydate As String, Countday As Integer) As String Dim kh_Calendar As Integer, m As Integer, d As Integer Dim Td As Date Dim sHi As String kh_Calendar = Calendar Calendar = vbCalHijri If IsDate(Mydate) Then m = Int(Countday / 30) d = Countday - (m * 30) Td = CDate(Mydate) Td = DateSerial(Year(Td), Month(Td) + m, Day(Td) + d) sHi = Format(Td - 1, "yyyy-mm-dd") If d Or Day(sHi) = 30 Then kh_MyTextHijri = sHi Else kh_MyTextHijri = Left(sHi, 8) & "30" End If End If Calendar = kh_Calendar End Function شاهد المرفق 2003 دالة خاصة لتسلسل التاريخ بطريقة غير نظامية على اساس كل شهر 30 يوم.rar

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

السلام عليكم فورم لحفظ نسخة من الملف بامكانية تغيير اسم الملف والمسار يعمل على اكسل 2003-2007 افتراضيا يعطيك نفس مسار الملف مع نسخة بتاريخ اليوم واذا تكرر الخفظ يخفظ فوق النسخة المحفوظة لتاريخ اليوم اما اليوم الثاني ستكون لك نسخة اخرى بتاريخه وبعدين لك الحرية في كل الاستخدمات اذا لم تريد ذلك تغيير المسار تعيير الاسم كما تريد وفيه امكانيات ستعجبكم كثيرا هديتي لكم لان كنت مقلا معكم هذه الايام فورم لحفظ نسخة من الملف.rar

السلام عليكم تم التعديل في UserForm1 عند اختيار معلم قد تم مسبقاً إدخال درجاته ستظهر بياناته امامك في الفورم وستظهر كلمة تعديل على الزر CommandButton2 عند اختيار معلم لم يتم مسبقاً إدخال درجاته ستظهر كلمة ترحيل على الزر CommandButton2 واذا لم تختار شيئا ستظهر كلمة اختر من القائمة على الزر CommandButton2 وقد تم اختصار الكود وفصل الاكواد حسب آلية عملها شاهد المرفق اكسل 2003 abuzainab73_form.rar

======================== الاخ الفاضل/ HaNcOcK ======================== عمل رائع جداً سلمت يداك و

السلام عليكم Sub khCopy_Rng() Dim Last As Long Dim MyCopy As Range, MyPost As Range With Sheets("1") Last = .Cells(.Rows.Count, "A").End(xlUp).Row Set MyCopy = .Range(.Range("A5"), .Cells(Last, "P")) End With With Sheets("2") Last = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 Set MyPost = .Cells(Last, "A") End With MyCopy.Copy MyPost MsgBox "تم الترحيل بنجاح" Set MyCopy = Nothing Set MyPost = Nothing End Sub شاهد المرفق اكسل 2003 ترحيل بيانات من ورقة الى اخرى.rar

السلام عليكم شاهد المرفق المرفق بمعيتها ملفين اكسل اكسل 2003 اكسل 2007 Test1.rar

======================== الاخ الحبيب/ احمد زمان ======================== و

السلام عليكم الحل بطريقتين : بمعادلة معمولة بالكود وباستخدام الكود المشمول ايضا على المعادلة بالضغط على زر الكود Option Explicit ' ' Sub kh_Test_MyFillName() Dim R As Long Columns("B:B").ClearContents Do R = R + 1 Cells(R, "B") = FilePath_Test(CStr(Cells(R, "A"))) Loop While Cells(R, "A") <> "" End Sub '======================================================= Function FilePath_Test(MyName As String) As Boolean Dim MyPath As String If Len(MyName) = 0 Then GoTo 1 MyPath = ThisWorkbook.Path & "\" & MyName & "*" FilePath_Test = Not Dir(MyPath, vbDirectory) = vbNullString 1: End Function المرفق بمعيتها ملفين اكسل اكسل 2003 اكسل 2007 Test.rar

السلام عليكم على حد علمي لا والله اعلم

السلام عليكم لقد تم التعامل مع الملف والحمد لله تم التعديل على الكود كما يلي: Option Explicit Option Compare Text ' اسم الورقة التي سيتم لصق البيانات فيها Const MySheet_Post As String = "post" ' Sub kh_copy_mydate() Dim sh As Worksheet Dim MyFilOpen As String, MyPath As String, MyBook As String '===================== On Error GoTo Err_mydate '===================== Set sh = ActiveWorkbook.Worksheets(ActiveSheet.Name) Application.ScreenUpdating = False '===================== With sh MyPath = CStr(.Range("C1")) & ":\" & CStr(.Range("D1")) & "\" MyBook = CStr(.Range("C16")) & File_Type(MyPath & .Range("C16")) End With '===================== Set sh = ActiveWorkbook.Worksheets(MySheet_Post) '===================== MyFilOpen = MyPath & MyBook '===================== If Dir(MyFilOpen, vbDirectory) = vbNullString Then MsgBox "رابط غير موجود" Else Workbooks.Open Filename:=MyFilOpen Sheets(1).Columns("A:A").Copy sh.Range("A1") Workbooks(MyBook).Close False MsgBox "تم نسخ البيانات الى الورقة : " & vbCr & MySheet_Post sh.Activate End If '===================== Err_mydate: If Err Then MsgBox "Err.Number:" & vbCr & Err.Number '===================== Application.ScreenUpdating = True Set sh = Nothing End Sub ------------------------------------ Function File_Type(MyTest As String) As String Dim MyType As String MyType = ".xls" If Not Dir(MyTest & MyType, vbDirectory) = vbNullString Then File_Type = MyType End If End Function شاهد المرفق tahar2.rar

السلام عليكم الكود يتعامل مع ملفات الاكسل التي من نوعية نوع الملف "xls" في بداية الكود ضع اسم الورقة التي تريد لصق البيانات فيها Const MySheet_Post As String = "post" وهذا الكود المستخدم: Option Explicit Option Compare Text ' اسم الورقة التي سيتم لصق البيانات فيها Const MySheet_Post As String = "post" ' Sub kh_copy_mydate() Dim sh As Worksheet Dim MyFilOpen As String, MyPath As String, MyBook As String '===================== On Error GoTo Err_mydate '===================== Set sh = ActiveWorkbook.Worksheets(ActiveSheet.Name) Application.ScreenUpdating = False '===================== With sh MyPath = CStr(.Range("C1")) & ":\" & CStr(.Range("D1")) & "\" MyBook = CStr(.Range("C16")) & ".xls" End With '===================== Set sh = ActiveWorkbook.Worksheets(MySheet_Post) '===================== MyFilOpen = MyPath & MyBook '===================== If Dir(MyFilOpen, vbDirectory) = vbNullString Then MsgBox "رابط غير موجود" Else Workbooks.Open Filename:=MyFilOpen Sheets(1).Columns("A:A").Copy sh.Range("A1") Workbooks(MyBook).Close False MsgBox "تم نسخ البيانات الى الورقة : " & vbCr & MySheet_Post sh.Activate End If '===================== Err_mydate: If Err Then MsgBox "Err.Number:" & vbCr & Err.Number '===================== Application.ScreenUpdating = True Set sh = Nothing End Sub شاهد المرفق اكسل 2003 tahar1.rar

السلام عليكم الاخ الفاضل/ بن عليه -----حفظه الله لك من الاجر بمثل دعائك واكثر اضعاف مضاعفة جزاك الله خيرا الاخ الفاضل الطيب / دغيدي -------حفظه الله مبروك على الترقية مرة اخرى وبارك الله فيك جزاك الله خيرا شاهدي المرفق اكسل 2003 مجموعات متسلسلة4.rar

السلام عليكم تم مراجعة المعادلات بحيث تكون معادلة وحدة يتم سحبها على كل صفوف الاعمدة c ,d ,e تفضل المرفق مجموعات متسلسلة.rar

السلام عليكم بارك الله فيك اخي ولكن اريد ان افهم المطلوب بشكل صحيح فلو ادخلنا رقمين من 150 : 372 اظن حيكون التالي: 150 : 199 200 : 249 250 : 299 300 : 349 350 : 372 و لو ادخلنا رقمين من 151 : 372 اظن حيكون التالي: 151 : 200 201 : 250 251 : 300 301 : 350 351 : 372 هل ما اوردته صحيحا ؟؟؟

السلام عليكم وهذه معادلة VLOOKUP لجلب الجنسية =VLOOKUP(VALUE(MID(A7;9;1));$G$1:$H$6;2;0)

السلام عليكم عفوا لم ارى مشاركة اختي الكريمة حفظها الله --------------------- لجلب التاريخ وتحويلة كتاريخ مباشرة استخدم المعادلة التالية: =DATE(MID(A7;1;4);MID(A7;5;2);MID(A7;7;2)) ثم قم بتنسيق الخلية كتاريخ كما تشاء شاهد المرفق اكسل 2003 سؤال.rar

السلام عليكم استخدم المعادلة التالية لجلب بيانات الجنسية =INDEX($H$1:$H$6;MID(A7;9;1)) ساعمل على تنسيق التاريخ وسارفق الملف

السلام عليكم حسب ما فهمت من طلبك اذا كانت المجموعة 50 مفروض تكون هكذا 1250 الى 1299 1300 الى 1349 1350 الى 1399 1400 الى 1444 وليس مثل ما اوردته في مرفقك الا اذا فهمت الموضوع بشكل خاطىء ولم افهم الجزئية الاخرى من السؤال هل تريدها في الجزء الثاني من الجدول ؟؟ شاهد المرفق اكسل 2003 مجموعات متسلسلة.rar

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

السلام عليكم في الخلية "C1" اسم الدرايفر في الخلية "D1" اسم المجلد وممكن يتفرع الى عدة مجلدات حينها ضع الشرطة "\" بين اسماء المجلدات مثلا : "MyDocument\tahar" في الخلية "C16" اسم ملف الاكسل واسماء الملفات تكون ارقام عادية بدون اضافة اصفار قبل الرقم وهذاالكود ادناه: Option Explicit Option Compare Text Sub kh_copy_mydate() 'On Error Resume Next Dim sh As Worksheet Dim MyFilOpen As String, MyPath As String, MyBook As String '===================== Set sh = ActiveWorkbook.Worksheets(ActiveSheet.Name) Application.ScreenUpdating = False '===================== With sh MyPath = CStr(.Range("C1")) & ":\" & CStr(.Range("D1")) & "\" MyBook = CStr(.Range("C16")) & ".xls" End With '===================== MyFilOpen = MyPath & MyBook '===================== If Dir(MyFilOpen, vbDirectory) = vbNullString Then MsgBox "error" Else Workbooks.Open Filename:=MyFilOpen Sheets(1).Select Columns("A:A").Copy sh.Range("A1") Workbooks(MyBook).Close False End If '===================== Application.ScreenUpdating = True Set sh = Nothing 'On Error GoTo 0 End Sub تفضل المرفق اكسل 2003 tahar1.rar

السلام عليكم سانظر اخي الحبيب نادر في طلبك ان شاء الله ================= اخي الحبيب طارق ---حفظه الله تصرف حكيم منك اخي الكريم زادك الله علما وحكمة وجزاك الله خيرا تقبلوا تحياتي وشكري ودمتم في حفظ الله

السلام عليكم عفوا على التاخير وشكرا على الدعاء غير الجزئية هذه من الكود ComboBox1_Change v = Application.Match(CDbl(ComboBox1), Range(ComboBox1.RowSource), 0) + 3 بهذه الجزئية: v = ComboBox1.ListIndex + 4 وقد ارسلت لك الحل عبر بريدك ايضا خبور خير