اذهب الي المحتوي
أوفيسنا

شوقي ربيع

الخبراء
 عرض الملف الشخصي  عرض المشاركات

  • Posts

    1,134

  • تاريخ الانضمام

  • تاريخ اخر زياره

  • Days Won

    13

 نوع المحتوي 

كل منشورات العضو شوقي ربيع

  1. شوقي ربيع
    السلام عليكم غير الكود السابق الخاص بنسخ الجدول بهذا الكود Sub Copeir_Tebel() 'لنسخ الجدول ايضا بنفس ارتفاع الصفوف Dim sh As Worksheet: Set sh = Sheets("data") Dim sh2 As Worksheet: Set sh2 = Sheets("مكافاة الثانوية العامة") Dim lr As Long: lr = sh2.Cells(sh2.Rows.Count, 1).End(xlUp).Row + 2 Dim i As Integer sh2.Rows("8:28").Copy sh2.Range("A" & lr + 5).Select ActiveSheet.Paste Dim Lrw As Long: Lrw = sh2.Cells(sh2.Rows.Count, 2).End(xlUp).Row Dim x As Integer: x = sh2.Range("A" & lr - 2) + 1 For i = lr + 5 To Lrw sh2.Range("A" & i) = x x = x + 1 Next ActiveSheet.PageSetup.PrintArea = "$A$1:$As" & Lrw Dim Str As Byte: Str = 34 FinalRow = Range("A65536").End(xlUp).Row For i = Str To Lrw Step 26 ActiveSheet.HPageBreaks.Add before:=Cells(i, 1) Next i End Sub تحياتي
  2. شوقي ربيع
    وهذا الحل بخصوص الترقيم تحياتي لك فكرة جديده للتخلص من مشكلة تذيل صفحات اوراق العمل - سعيد بيرم.rar
  3. شوقي ربيع
    السلام عليكم اعتذر لعدم اكمالي في الموضوع نضرا لاني كنت مشغول في الايام القليلة التي مضت اما بخصوص ما طلبت اضن ان هذا هو المطلوب '####### RABIE CHAOUKI ######### Sub Copeir_Data() ' áäÓÎ ÇáÊÐíá ÈäÝÓ ÚÑÖ ÇáÕÝæÝ Ýí ÕÝÍÉ ÇáÏÇÊÇ ÍÊì Çä ÛíÑÊ ÇáÇÑÊÝÇÚ Dim sh As Worksheet: Set sh = Sheets("data") Dim sh2 As Worksheet: Set sh2 = Sheets("ãßÇÝÇÉ ÇáËÇäæíÉ ÇáÚÇãÉ") Dim lr As Long: lr = sh2.Cells(sh2.Rows.Count, 1).End(xlUp).Row + 2 sh.Rows("1:5").Copy sh2.Range("A" & lr).Select: ActiveSheet.Paste End Sub Sub Copeir_Tebel() 'áäÓÎ ÇáÌÏæá ÇíÖÇ ÈäÝÓ ÇÑÊÝÇÚ ÇáÕÝæÝ Dim sh As Worksheet: Set sh = Sheets("data") Dim sh2 As Worksheet: Set sh2 = Sheets("ãßÇÝÇÉ ÇáËÇäæíÉ ÇáÚÇãÉ") Dim lr As Long: lr = sh2.Cells(sh2.Rows.Count, 1).End(xlUp).Row + 2 sh2.Rows("8:28").Copy sh2.Range("A" & lr + 5).Select ActiveSheet.Paste lr = sh2.Cells(sh2.Rows.Count, 2).End(xlUp).Row ActiveSheet.PageSetup.PrintArea = "$A$1:$AD" & lr Dim Str As Byte: Str = 34 Dim i As Integer FinalRow = Range("A65536").End(xlUp).Row For i = Str To lr Step 26 ActiveSheet.HPageBreaks.Add before:=Cells(i, 1) Next i End Sub Sub main() ' áÇÓÊÏÚÇÁ ÇæÇãÑ äÓÎ ÇáÊÐíá æÇáÌÏæá Dim MSG, MSG2: MSG = MsgBox("åá ÊÑíÏ äÓÎ ãÍÊæì ÇáÊÐíá ÇáãØáæÈ", vbYesNo) If MSG = vbYes Then Call Copeir_Data MSG2 = MsgBox("åá ÊÑíÏ äÓÎ ÇáÕÝæÝ ãä 8 Çáì 28", vbYesNo) If MSG2 = vbYes Then Call Copeir_Tebel Else: End End If Else: End End If End Sub فكرة جديده للتخلص من مشكلة تذيل صفحات اوراق العمل - سعيد بيرم.rar
  4. شوقي ربيع
    السلام عليكم فكرة جديده للتخلص من مشكلة تذيل صفحات اوراق العمل - سعيد بيرم.rar
  5. شوقي ربيع
    السلام عليكم اول يجب عدم تغير تسمية الصفحات فان غيرتها يجب التعديل في الاكواد اما الحل هو فقط اضغط على F2 وشاهد بنفسك تحياتي فكرة جديده للتخلص من مشكلة تذيل صفحات اوراق العمل - سعيد بيرم.rar
  6. شوقي ربيع
    السلام عليكم هذا البرنامج صممته على طلب احد الاصدقاء لاكن اعجبني فعلا رائيك حول التقارير من المفروض انه هكذا تكون الردود عبارة عن استفسارات او ملاحظات او تعقيبات مثل ما تفضلت لكي يكون هناك تطور لأي موضوع يدرج في المنتدى مهما كان كبير ا او صغيرا تحياتي لك وشكرا
  7. شوقي ربيع
    السلام عليكم تلك الرسالة تفيد بان تغلق أي ملف اكسل مفتوح قبل فتح البرنامج تفضل هذا الملف الاساسي Archivé Mobile V 1.001.rar
  8. شوقي ربيع
    تفضل اخي البرنامج في المرفق مع العلم اني لم اجربه من قبل لاكن اضن انه يعمل بنفس الطريقة التي يعمل بها برنامج تحويل الاكسل الى ملف تنفيذي شاهد هذا الموضوع لتستوعب طريقة سير عمل البرنامج شرح تحويل ملف الاكسل الى exe ثم تغيير الايقونة ثم Setup... DBtoEXE.zip
  9. شوقي ربيع
    في الكود الاخير ضع textbox1 مكان x فقط WebBrowser1.Navigate _ "ABOUT:<HTML><CENTER><HEAD><body scroll='no' LEFTMARGIN=0 TOPMARGIN=0><IMG WIDTH=" & _ Large & " HEIGHT=" & Haut & _ " SRC='" & textbox1.value & "'</IMG></BODY></CENTER></HTML>"
  10. شوقي ربيع
    هناك مشكلة في الرفع على gulfup تفضل حملته على mediafire http://www.mediafire.com/download/mmz502qibcm0f7k/Archivé_Mobile_V_1.001.rar وايضا اعدت رفعه على المنتدى برغم من ان الرابط الاول يعمل عادي تحياتي Archivé Mobile V 1.001.rar
  11. شوقي ربيع
    السلام عليكم المشكلة التي ظهرت لديكما راجعة الى دالتي format و الداله date وهذا راجع الى نسخة الويندوز التي تستعملانها والضاهر انها نسخة XP عربية والبرنامج صمم على ويندوز 7 فرنسية المشكلة هنا هو عدم توافق الدالتين المذكورتان سابقا مع التي هي على نسخة الويندوز لديكما تحياتي
  12. شوقي ربيع
    السلام عليكم يمكن استعمال اداة WebBrowser لتحقيق هذا مع هذا الكود الذي هو عبارة عن دمج بين vba & html Dim x As String Dim Haut As Long, Large As Long Large = WebBrowser1.Width * 96 / 72 Haut = WebBrowser1.Height * 96 / 72 x = "http://kenanaonline.com/photos/1238119/1238119839/large_1238119839.jpg" ' Ýí ÍÇáÊ ãÇ ÇÐÇ ßÇä åäÇß ãÓááÓá áÕæÑ ßá ãÇ Úáíß ÇáÊáÇÚÈ Ýí ÇáãÊÛíÑ x 'ãËáÇ ' x = "http://kenanaonline.com/photos/1238119/1238119839/&åäÇ ÖÚ ÇÓã ÇáÕæÑÉ Çæ ÇáãÊÛíÑ ÇáÐí íÍãá ÇÓã ÇáÕæÑÉ áÚÑÖåÇ &.jpg" WebBrowser1.Navigate _ "ABOUT:<HTML><CENTER><HEAD><body scroll='no' LEFTMARGIN=0 TOPMARGIN=0><IMG WIDTH=" & _ Large & " HEIGHT=" & Haut & _ " SRC='" & x & "'</IMG></BODY></CENTER></HTML>" ;وبما انك تتبع تسلسل لصور كل ما عليك هو التلاعب في المتغير x عرض الصورة التي تريد عرضها من النت سلام عرض صورة في الفورم من النت.rar
  13. شوقي ربيع
    احذف هذا الكود Lr = Cells(Rows.Count, "B").End(xlUp).Row واين تجد عبارة lr استبدلها ب الرقم الذي تريده
  14. شوقي ربيع
    Option Explicit Sub test() Dim sh As Worksheet, Ws As Worksheet: Set sh = Sheets("غير مكتمل") Dim lr As Long, Lrw As Long Dim i As Integer, r As Integer lr = sh.Cells(sh.Rows.Count, 2).End(xlUp).Row + 1 sh.Range("C11:AI" & lr).ClearContents For Each Ws In Worksheets Lrw = Ws.Cells(Ws.Rows.Count, 2).End(xlUp).Row + 1 For i = 11 To Lrw lr = sh.Cells(sh.Rows.Count, 2).End(xlUp).Row + 1 If Ws.Range("AI" & i) = "لا" Then sh.Range("B" & lr) = lr - 10 For r = 3 To 35 sh.Cells(lr, r) = Ws.Cells(i, r) Next r End If Next i Next Ws End Sub
  15. شوقي ربيع
    السلام عليكم Option Explicit Sub test() Dim sh As Worksheet, Ws As Worksheet: Set sh = Sheets("غير مكتمل") Dim lr As Long, Lrw As Long Dim i As Integer, r As Integer lr = sh.Cells(sh.Rows.Count, 2).End(xlUp).Row sh.Range("C11:AI" & lr).ClearContents For Each Ws In Worksheets Lrw = Ws.Cells(Ws.Rows.Count, 2).End(xlUp).Row + 1 For i = 11 To Lrw lr = sh.Cells(sh.Rows.Count, 2).End(xlUp).Row + 1 If Ws.Range("AI" & i) = "لا" Then For r = 3 To 35 sh.Cells(lr, r) = Ws.Cells(i, r) Next r End If Next i Next Ws End Sub وثائق.rar
  16. شوقي ربيع
    السلام عليكم فورم الدرجات1.rar
  17. شوقي ربيع
    النتائج تظهر في العدد القادم للمجلة
  18. شوقي ربيع
    ان كان الاوفيس عندك عربي او انجليزي غير Dim sh As Worksheet, ws As Worksheet: Set sh = Feuil1 الى Dim sh As Worksheet, ws As Worksheet: Set sh = Sheet1
  19. شوقي ربيع
    السلام عليكم خذ هذا الكود يرحلك اسم المعلم حسب المدرسة مهما كان عددهم المهم هو ان تكون اسماء الشيتات بأسماء المدارس صحيحة فقط كما في ملفك يمكنا زيادت ما تشاء من مدارس Sub test() Dim sh As Worksheet, ws As Worksheet: Set sh = Feuil1 Dim lr As Long: lr = sh.Cells(sh.Rows.Count, "C").End(xlUp).Row Dim i As Integer For i = 2 To lr Dim NomScol As String: NomScol = sh.Range("L" & i) For Each ws In Worksheets Dim NomWs As String: NomWs = ws.Name If NomWs = NomScol Then Set ws = Sheets(NomWs) Dim lrw As Long: lrw = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1 Dim r As Integer For r = 1 To 14 ws.Cells(lrw, r) = sh.Cells(i, r + 2) Next End If Next ws Next End Sub تحياتي
  20. شوقي ربيع
    السلام عليكم تم تطوير الكود حيث يمكن استعماله في عدت فورمات دون تكرار كتابة الاكواد وايضا اضفة اليوم الحالي مع الوقت ضع هذا الكود في ميودل Option Explicit Public Sub Timer(Frm As Object, LTime As String, LDate As String, Start As Boolean) If Start = False Then End Do While Start If LTime <> "" Then Frm.Controls(LTime).Caption = Time If LDate <> "" Then Frm.Controls(LDate).Caption = Date DoEvents Loop End Sub اما هذا الكود ضعه في الفورم الذي تريد ان تضهر فيه الساعة واليوم Private Sub UserForm_Activate() Timer Me, "Label1", "Label2", True End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Timer Me, "", "", False End Sub فقط قم بكتابة اسم الليبل الدي تريد ان تضهر فيه الساعة او التاريخ مكان Label1 و Label2 على التاوالي وان اردت عدم عرض التاريخ او الوقت فقط اترك مكانه فارغ تحياتي
  21. شوقي ربيع
    السلام عليكم بالفعل كما قال اخي حمادة ان الكود المستعمل لأضهار الساعة هو المتسبب في المشكلة لكنني أفضل استعمل الحلقة Do عن الحلقة for لأنها اسرع في التنفيذ و ايضا لا تحتاج بداية ونهاية فقط تحتاج الى شرط المهم جرب هذا الكود Private Sub UserForm_Activate() Time True End Sub Sub Time(Start As Boolean) Dim Secondes, N Secondes = 1# Do While Start N = Now Me.CLOCK.Caption = Format(N, "h:mm:ss AM/PM") DoEvents Loop End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Time False End End Sub تحياتي
  22. شوقي ربيع
  23. شوقي ربيع
    هل كانت تضهر هته الرسالة قبل نقلك للملفات هذا الجزء خاص بحدث تحريك الماوس حيث الخطاء ان الكود لم يجد الصورة في الامج ليست الثانية هل عدلت شيء في الامج ليست ؟
  24. شوقي ربيع
    السلام عليكم الخطاء الناتج على حسب الصورة ان الكود لم يجد ملف الصور المسمى Image يجب وضع الملف ومجلد الصور في مكان واحد بعد فك الضغط عنهما جرب وضعهما معا في مجلد جديد واعلمني بالنتيجة تحياتي
  25. شوقي ربيع
    اللهم امين يارب العالمين
×
×
  • اضف...

Important Information

  I accept