الـعيدروس

السلام عليكم الاخ طاهر عند ظهور الرسالة إضغط OK ثم إذهب إلى قوائم المحرر قائمة Tools ثم References وأعطني الجمله المضلل عليها ربما الاداة ListView ليست معرفة لدية

السلام عليكم جرب هذه الطريقة هذه الأكواد في حدث الورقة ورقة1 Private Sub Worksheet_Activate() ALI_A = 1 End Sub Private Sub Worksheet_Deactivate() ALI_A = 0 End Sub وهذا الكود في مدويل Option Explicit Public ALI_A As Integer Public Sub T_PTh() On Error Resume Next Dim PaTh_A As String, R_Va As Byte PaTh_A = "D:\" & [b3] & "\" & [C3] & ".xlsx" R_Va = D_N(PaTh_A) If R_Va Then MsgBox "غير موجود" Else If Val(ALI_A) = 1 Then GoTo 1 Dim AA% Const P As String = "123" AA = InputBox("إدخل تصريح فتح الملف", "منتدى أوفسينا") If AA = P Then MsgBox "موجود" Workbooks.Open Filename:=PaTh_A Range("A1").Select Else MsgBox "كلمة المرور خطاء", vbExclamation, "تنبية !!!" Exit Sub End If End If 1: Workbooks.Open Filename:=PaTh_A Range("A1").Select End Sub Private Function D_N(D_E As String) As Byte On Error GoTo P D_N = IIf(Len(Dir(D_E)) > 1, 0, 1) Exit Function P: D_N = 2 End Function جرب الكود وابلغنى بالنتائج والسلام عليكم

السلام عليكم الملف الذي في الرابط جربته بيعمل بكفائة

السلام عليكم الاخ سامي راجع هذا الرابط مشاركة رقم 26 به ماتريد وأكثر http://www.officena.net/ib/index.php?showtopic=40731&st=20

السلام عليكم إطلع على المرفق هل هكذا يفي بالغرض وأي ملاحظات أخ طاهر مايردك إلا الكيبورد والسلام عليكم Taher_TQ.rar

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

السلام عليكم اكواد جميله اخ محمد مصطفى جزاك الله الف خير تقبل مروري

إستبدل السطر الاخير الذي هو .Rows(Last).Copy .Rows(Last + 1).Resize(Count) بهذا .Rows(Last).Copy .Rows(Last + 1).Resize(Count - 1)

السلام عليكم جزاك الله خير على هذا الكود الجميل معلومه بسيطه بعد اذنك في وضعه الحالي يوضع في مودويل مرمزAuto_Open يعني يعمل الكود دايركت عند فتح المصنف

السلام عليكم جرب هذا التعديل Sub KH_Copy() On Error Resume Next Dim Last As Long Dim Count As Integer Count = 1 Count = Sheets("بيانات اساسية").Range("I2").Value With ActiveSheet Application.ScreenUpdating = False .Range(Cells(12, 1), Cells(Rows.Count, 150)).EntireRow.Delete Last = .Range("W" & .Rows.Count).End(xlUp).Row .Rows(Last).Copy .Rows(Last + 1).Resize(Count) Application.ScreenUpdating = True End With On Error GoTo 0 End Sub

السلام عليكم الاخ الفاضل temo002 لم توضح طلبك في المرفق طلبك فاتورة والمرفق يحكي شيء اخر

السلام عليكم الاخ الفاضل mhrrd ارجو منك ارفاق مثال لما تريد لم تتضح الصورة لدي

السلام عليكم الاخ الفاضل طاهر بداية اشكرك ولك مثل دعائك اضعاف مضاعفة ان شاء الله - بالنسبة للتغيير كيف أعدل ا الكود حيث يقتصر على الشيت bd فقط ========================== اذهب الى هذا السطر If ActiveSheet.Name = "My_Con" Or ActiveSheet.Name = "Search Result" Then Exit Sub[/color][/font][/right] [font="tahoma, arial, verdana, sans-serif"][color="#282828"] وعدل عليه ليصير If ActiveSheet.Name <> "bd" Then Exit Sub وهل بالإمكان أنا أختار إختيار الورقة التي جرى فيها التعديل من قائمة ==================================== بالامكان ذلك لاكن احتاج بعض الوقت لاهنت ==================================== بالنسبة للفورم بحث عن التعديلات كيف إعدل في أسماء الأعمدة مثلا كلمة مسلسل أريد تغييرها وكيف أضيف متغيرت في list view ============================== اذهب الى هذا السطر في حدث الفورم Private Sub CO_A() With Me.ListView1 .ColumnHeaders.Add(1) = "مسلسل" وغير كلمة مسلسل إلى أي كلمة تحب ============================== في مكان خلية التعديل أريد ان يصهر القيد مباشرة =================== هذا حل مؤقت إلى أن اجد طريقة بإستخدام Hyperlin إذهب إلى هذا السطر في حدث Thisworkbook .Value = ActiveSheet.Name & ":" & Target.Address احذفة وضيف هذا السطر .Hyperlinks.Add Anchor:=.Offset(0, 0), Address:="", SubAddress:=(ActiveSheet.Name) & "!" & (Target.Address) أي إضافات أو تعديلات أنا موجود والسلام عليكم

السلام عليكم تفضل Sub macro2() On Error Resume Next Application.ScreenUpdating = False Dim S_ALI As Worksheet Dim X_ALI& Dim R_ALI As Range Set S_ALI = Sheets("بيانات") ActiveSheet.Range(Cells(7, 2), Cells(Rows.Count, 9)).Clear With S_ALI X_ALI = .Cells(Rows.Count, "R").End(xlUp).Row Set R_ALI = .Range("B7:R" & X_ALI) R_ALI.Copy ActiveSheet.Range("B7").PasteSpecial xlPasteValues Application.CutCopyMode = False End With Application.ScreenUpdating = True UserForm1.Show 0 End Sub

السلام عليكم الشرح في المرفقات امل ان اكون وفقت في الشرح شرح.rar

السلام عليكم وجرب هكذا Sub KH_Copy() On Error Resume Next Dim Last As Long Dim Count As Integer Count = 1 Count = Sheets("KHBOOR").Range("F9").Value With ActiveSheet A = .Cells(1, 1).End(xlDown).Offset(1, 0).Row .Range(Cells(A, 1), Cells(Rows.Count, 5)).EntireRow.Delete With Cells(A, 1) .FormulaR1C1 = "=ROW()-9" .Font.Size = 12 .Font.Bold = True .Offset(0, 4).FormulaR1C1 = "=SUM(RC[-4]:RC[-1])" .Offset(0, 4).Font.Size = 20 .Offset(0, 4).Font.Bold = True End With With Cells(A, 1).Resize(1, 5) .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Borders.Color = 1 .Font.Color = RGB(0, 51, 102) End With Last = .Range("A" & .Rows.Count).End(xlUp).Row .Rows(Last).Copy .Rows(Last).Resize(Count) .Rows(Last).Resize(Count).SpecialCells(xlConstants).ClearContents End With On Error GoTo 0 End Sub

السلام عليكم نرجو إرفاق مثال وعلية شكل الفاتورة المطلوب وشرح بسيط للالية المطلوبة وإن شاء الله لن يقصر الجميع في تقديم المساعده

السلام عليكم الاخ الفاضل cat101 حفظك الله كلنا نتعلم من بعض نحنو في بداية الطريق وفقك الله لما فيه الخير هل نتائج الكود مزبوطه ؟

تفضل عرفت طلبك من حل الأخ الفاضل cat101 وبعد اذنه تفضل Sub KH_Copy() On Error Resume Next Dim Last As Long Dim Count As Integer Count = 1 Count = Sheets("KHBOOR").Range("F9").Value With ActiveSheet A = .Cells(1, 1).End(xlDown).Offset(2, 0).Row .Range(Cells(A, 1), Cells(Rows.Count, 5)).EntireRow.Delete Last = .Range("A" & .Rows.Count).End(xlUp).Row .Rows(Last).Copy .Rows(Last + 1).Resize(Count) .Rows(Last + 1).Resize(Count).SpecialCells(xlConstants).ClearContents End With On Error GoTo 0 End Sub

السلام عليكم اخي طاهر بالنسبة لرسالة الخطاء ربما لانك بتعمل على أوفيس 2003 ونظرا لوجود دالات VBA في 2007 لاتعمل في 2003 وهذا مؤكد ولاكن جرب المرفق بعد حذف تنسيق التعليق أعتقد ربما بسببه وإضافة ماوعدتك به فورم بحث وهو من عمل سابق modi_ALI_1.rar

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

السلام عليكم حل بالإستعانه بدالة VLOOKAnyCol للاستاذ القدير ابو تامر حفظه الله تفضل المرفقات منظومة المخازن_ALI.rar

السلام عليكم السموحه توضيح اكثر

السلام عليكم استخدم هذه الأكواد ومن ضمنها كود الاستاذ القدير خبور خير عملها لإخفاء شريط ابداء عند فتح الفورم وإظهاره عند اغلاق الفورم Private Const SWP_HIDEWINDOW = &H80 Private Const SWP_SHOWWINDOW = &H40 Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Private Sub UserForm_Activate() Dim T As Long T = FindWindow("Shell_traywnd", "") Application.EnableEvents = False Call SetWindowPos(T, 0, 0, 0, 0, 0, SWP_HIDEWINDOW) Application.EnableEvents = True End Sub Private Sub UserForm_Initialize() Me.Width = Application.Width Me.Height = Application.Height End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Dim T As Long T = FindWindow("Shell_traywnd", "") Application.EnableEvents = False Call SetWindowPos(T, 0, 0, 0, 0, 0, SWP_SHOWWINDOW) Application.EnableEvents = True End Sub

السلام عليكم الاخ الفاضل طاهر بالنسبة للفورم البحث حسب التاريخ اذا يلزم ارجو منك اعطائي بعض الوقت لاني مشغول شويات