شوقي ربيع

تحية كبيرة للأخ ياسر خليل وجازاه الله خيرا على متابعة الموضوع تفضل اخي الكريم Sub test() Dim sh As Worksheet: Set sh = Feuil4 Dim Lr As Long: Lr = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row - 1 Dim Text As String Dim i As Integer, r As Integer, x As Integer, xx As Integer r = 0 For i = 2 To Lr x = Val(sh.Range("A" & i + 1)) - Val(sh.Range("A" & i)) Select Case x Case Is > 1 For xx = 2 To x r = r + 1 Text = Text & Val(sh.Range("A" & i)) + xx - 1 & vbCrLf Next End Select Next MsgBox Text End Sub تحياتي للجميع

السلام عليكم الشكر موصول للأخ سليم حاصبيا للإفادة هذا حل عن طريق الاكواد Sub test() Dim sh As Worksheet: Set sh = Feuil4 Dim Lr As Long: Lr = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row - 1 Dim i As Integer, r As Integer, x As Integer, xx As Integer For i = 2 To Lr x = Val(sh.Range("A" & i + 1)) - Val(sh.Range("A" & i)) Select Case x Case Is > 1 For xx = 2 To x r = r + 1 sh.Range("O" & r).Value = Val(sh.Range("A" & i)) + xx - 1 Next End Select Next End Sub تحياتي للجميع

لاداعي الى ان تفرمت جهازك سوف اعمل على ايجاد حل اخر المشكلة في تنفيذ الكود اوتوماتيكيا لو تعملو زر تنفيذ (يدوي يعني) راح يشتغل عادي

قم بتغير الكود المحدد باللون الاصفر بهذا WrSh.Activate

وعليكم السلام ورحمة الله وبركاته شكرا على مرورك بالموضوع بخصوص ملاحظتك تم التنويه اليها في المشاركة رقم 12 تحياتي

السلام عليكم لم افهم الاشاء التي لا تفتح عندك كما ان الملف مربوط ببرنامج خارجي اضن اه مستشار او ماشابه يجب ان يكون مثبت لديك على الجهاز لكي تضهر عند النتائج تحياتي

السلام عليكم تم عمل المطلوب بالمرفق ادناه مع مراعات ان رؤوس الاعمدة تكون عبارة عن تواريخ بدل مما ذكرة اعلى1, اعلى2 ...... وذلك لكي يتعرف الكود هل تم الترحيل في ذلك اليوم ام لا كما لاحظة انه يمكن لكود الترحيل ان يسبق استقبال بالبيانات من المصدر الخارجي في حالت فتح الملف بعد الساعة الثلاثة مساءا لذى تم اضافة كود عند اقلاع الملف يأخر عملية الترحيل 30 ثانية لإعطاء الملف فرصة في جلب البيانات من المصدر الخارجي ان لم تكن المدة كافية فما عليك سوى زيادة مدة التأخير في هذا الكود Private Sub Workbook_Open() Application.OnTime Now + TimeValue("00:00:30"), "Verification" End Sub الاكود المستعمل في عملية الترحيل Option Explicit Dim Sh As Worksheet, WrSh As Worksheet Sub Envoi() Dim Nm As Byte For Nm = 3 To 8 Set WrSh = ThisWorkbook.Sheets(Nm) WrSh.Select If WrSh.Range("D1") <> "" Then WrSh.Range(Columns(3), Columns(3).End(xlToRight)).Cut Destination:=Range("D1") Else WrSh.Columns(3).Cut Destination:=Range("D1") End If WrSh.Columns(2).Copy WrSh.Range("C1").PasteSpecial Paste:=xlPasteValues, _ Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False WrSh.Range("C1") = Date Next End Sub Sub Verification() Dim Nm As Byte For Nm = 2 To 7 Set WrSh = ThisWorkbook.Sheets(Nm) If WrSh.Range("C1") = Date Then Exit Sub If Time > TimeValue("15:00") Then Envoi Next End Sub ايضا يمكنك التعديل في الوقت الذي ان يتم الترحيل فيه من هذا الكود تحياتي للجميع تداول على االاكسل اوفسينا.rar

السلام عليكم كما ذكر الاستاد دغيدي الملف لا يحوي اكواد ولا معادلات هي مجرد صورة و لتشغيل ساعة او أي ملف من نوع swf على أي اصدار تحتاج الى ادراج اداة WebBrowser في الشيت او في الفورم من صندوق الادوات الاضافية وان يكون لديك ملف فلاشي للساعة ثم تربط الاداة بمسار الملف الفلاشي Me.WebBrowser1.Navigate "هنا ضع مسار الملف الفلاشي"

السلام عليكم استبدل اكواد الملف بهذه الاكواد Option Explicit Sub Hidden2() Dim Cl As Range Application.ScreenUpdating = False For Each Cl In Range("A14:A213") If Cl = "" Then Cl.EntireRow.Hidden = True End If Next Cl [kh_Row2] = "اضهار جميع الصفوف الفارغة" Application.ScreenUpdating = True End Sub Sub UnHidden2() Dim Cl As Range Application.ScreenUpdating = False For Each Cl In Range("A14:A213") If Cl.EntireRow.Hidden = True Then Cl.EntireRow.Hidden = False End If Next Cl [kh_Row2] = "اخفاء الصفوف الفارغة " Application.ScreenUpdating = True End Sub Sub Rows() ActiveSheet.Unprotect If [kh_Row2] = "اضهار جميع الصفوف الفارغة" Then UnHidden2 Else Hidden2 End Sub تحياتي

السلام عليكم يسعدني دائما مرورك العطر تحياتي لك

السلام عليكم شكرا على مرورك ودعائك الجميل تحياتي

السلام عليكم الملف الذي ارفقته لك في المشاركة رقم 14 يقوم تماما بما طلبته الا انه يعتمد على تاريخ اليوم في رؤوس الاعمدة بدل اعلى1 و اعلى2 ...... وذلك لنتمكن من معرفة هل تم الترحيل في ذلك اليوم ام لا تاكد من الملف وان كان مثل ما تريد سأقوم بنقل الاكواد الى الملف الاخير الخاص بك

السلام عليكم قم بنسخ هذا الكود في زر الحفظ للفورم الثاني مع مراعات ان تكست shipment no يجب ان تحوي ارقام لا غير Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("OPCDATA") Dim iRow As Long: iRow = ws.Cells(Rows.Count, 2).End(xlUp).Row Dim Mh As Long Dim i As Integer Dim ii As Double Dim Msg If Me.TextBox1 <> "" Then ii = Me.TextBox1.Value On Error GoTo Msg Mh = WorksheetFunction.Match(ii, ws.Range("B2:B" & iRow), 0) + 1 For i = 6 To 11 ws.Cells(Mh, i).Value = Me.Controls("Textbox" & i).Value Next Me.ComboBox1 = "" Me.TextBox1 = "" For i = 6 To 11 Me.Controls("Textbox" & i) = "" Next Me.TextBox1.SetFocus Exit Sub Msg: MsgBox "No Results" تحياتي

السلام عليكم ان وجدت عبارة Option Explicit في بداية الاكواد قم بحذفها او قم بتعريف المتغيرات الغير نعرفة لديك

السلام عليكم جزاك الله خير وشكرا على مرورك تحياتي

السلام عليكم بارك الله فيك على مرورك العطر وعباراتك الجميلة تقبل مني تحياتي

كل ما عليك هو تصميم شيت تكون فيه خلايا الادخالات متطابقة مع الوثيقة لديك ثم قم بالطباعة على الوثيقة نفسها تحياتي

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

ملاحظة الاصدار الحديث للأوفيس 2013 لا يدعم هذه الاداة

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

بارك الله فيك على مرورك والله يسلمك تحياتي

لك مني جزيل الشكر على عبارتك الجميلة واحمد الله اني كنت سببا في حبك للفورم تحياتي لك

بإذن الله لن نبخل بشيء عنكم اخوتي في الله تحياتي لك

اخي وصديقي ضاحي الغريب يشرفني ويسعدني مرورك العطر تحياتي لك

بسم الله الرحمان الرحيم السلام عليكم حركة اليوم كالعادة متعلقة بالجانب الفني و الجمالي لليوزر فورم اقتبست هاته الفكرة من تجليد الفورم في VB6 و VBNET بواسطة أداة Active Skin و وجدة ان هاته الأداة متوفر او متوافقة بالفعل مع VBA لذى بحثت وحاولت الى ان توصلت الى الاتي ا36 شكل (ثيم) مميز يمكنكم استعمالها بسهولة فس برامجكم ندخل الى التنفيذ اولا نحتاج الى تثبيت الأداة ActiveSkin Control ان لم تكن مثبت لديكم ولفعل ذالك اتبع الشرح المصور الاتي بهده الطريقة نكون انتهينا من عملية تثبيت الادات الان ناتي الى اضافة الاداة كاي ادات اخرى الى صندوق الادواة نقوم الان باضافة الاداة الى الفورم وايضا نقوم باضافة ليست بوكس ثم قم بنسخ هذا الكود في الفورم Option Explicit Private No As Double Private FSO As Object, Klasir As Object, Dosya As Object Private SeçilenDosya As String Private Const hWnd As Long = &H0 Private Sub UserForm_Initialize() On Error Resume Next Application.Visible = False With Me .Caption = "UserForm Skin" .Height = 226 .Width = 358 End With With ComboBox1 .Left = 6 .Top = 6 .Height = 18 .Width = 114 End With Call SkinDosyaListele End Sub Private Sub UserForm_Terminate() On Error Resume Next Contrôle1.Empty End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) On Error Resume Next Application.Visible = True End End Sub Private Sub ComboBox1_Change() On Error Resume Next SeçilenDosya = ComboBox1.List(ComboBox1.ListIndex, 1) Me.Caption = ComboBox1 With Contrôle1 .LoadSkin SeçilenDosya .ApplySkin hWnd .ZOrder 1 End With DoEvents End Sub Sub SkinDosyaListele() On Error Resume Next No = 0 Set FSO = VBA.CreateObject("Scripting.FileSystemObject") Dim Pth As String: Pth = ThisWorkbook.Path & "\Skins\" Set Klasir = FSO.GetFolder(Pth) For Each Dosya In Klasir.Files ComboBox1.AddItem Dosya.Name ComboBox1.List(No, 1) = Dosya No = No + 1 Next Dosya End Sub تم ارفاق مثال عملي للموضوع لكي يشتغل عنك المثال قم اولا بتثبيت الادات كما وضحت سابقا ولا تنسى وضع الملف بعد الحفظ مع مجلد Skins في نفس المسار سيضهر لك يوزر فورم به قائمة منسدلة بالشكل العادي قم باختيار أي اسم من القائمة ولاحظ مايحدث المجلد Skins يحوى السناكات بعض الصور المأخوذة للفورم بعد التجليد اهدي هذه الحركة الى اخي وصديقي ضاحي الغريب الذي عمل لي الشرح المصور اعلاه جازاه الله عنا كل الخير ارجو ان يفيدكم الموضوع وينال اعجابكم تحياتي للجميع اخوكم في الله شوقي ربيع الشرح المصور.rar ACTSKIN4 الاداة.rar مثال عملي عن تجليد الفورم.rar