محمد الورفلي1

السلام عليكم انظر المرفق 1(3).rar

السلام عليكم تفضل سؤال2.rar

كيف اجعل المؤشر يتجة لي تكست 4 مجرد الظغط علي جديد

شكراً استاذ ياسر

السلام عليكم اريد في الفورم عند الظغط علي مفاتح جديد يتم ادراج رقم جديد في التكست فورم 1.rar

للفائدة وجدت هذا الكود لااستاذ محمدصالح وهذا الرابط http://www.officena.net/ib/topic/46101-طلب-تعديل-كود-لإظهار-الرقم-السري-على-شكل-نجوم/ Option Explicit '//////////////////////////////////////////////////////////////////// 'Password masked inputbox 'Allows you to hide characters entered in a VBA Inputbox. ' 'Code written by Daniel Klann 'March 2003 '//////////////////////////////////////////////////////////////////// 'API functions to be used Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _ ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _ (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, _ ByVal dwThreadId As Long) As Long Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _ (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, _ ByVal lpClassName As String, _ ByVal nMaxCount As Long) As Long Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long 'Constants to be used in our API functions Private Const EM_SETPASSWORDCHAR = &HCC Private Const WH_CBT = 5 Private Const HCBT_ACTIVATE = 5 Private Const HC_ACTION = 0 Private hHook As Long Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Dim RetVal Dim strClassName As String, lngBuffer As Long If lngCode < HC_ACTION Then NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam) Exit Function End If strClassName = String$(256, " ") lngBuffer = 255 If lngCode = HCBT_ACTIVATE Then 'A window has been activated RetVal = GetClassName(wParam, strClassName, lngBuffer) If Left$(strClassName, RetVal) = "#32770" Then 'Class name of the Inputbox 'This changes the edit control so that it display the password character *. 'You can change the Asc("*") as you please. SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0 End If End If 'This line will ensure that any other hooks that may be in place are 'called correctly. CallNextHookEx hHook, lngCode, wParam, lParam End Function Public Function InputBoxDK(Prompt, Optional Title, Optional Default, Optional XPos, _ Optional YPos, Optional HelpFile, Optional Context) As String Dim lngModHwnd As Long, lngThreadID As Long lngThreadID = GetCurrentThreadId lngModHwnd = GetModuleHandle(vbNullString) hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID) InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context) UnhookWindowsHookEx hHook End Function 'Hope someone can use it! Sub TEST() Dim strAdminPWord As String strAdminPWord = InputBoxDK("Password required to proceed.", "Enter Licence Code") If strAdminPWord = "password" Then MsgBox "cool Password Correct ", vbOKOnly, "success" Else MsgBox ("You entered an invalid password") ' Exit Sub End If End Sub

بارك الله فيك تمام بس ا لرقم يكو ن *** نجوم

السكم عليكم هل يمكن استدعاء فورم برقم سري بمعنى عند الظغط علي مفتاح فورم الموجود في الشيت لايظهر الفوم الا بعد وضع رقم سري فورم.rar

شكراً استاذ رجب تمام التمام

فعلت لالكن انظر

السلام عليكم عند وضع خماية على الورقة ظهر لى خطاء في كلا الكودين ما الحل ايصالي1.rar ايصالي1.rar

ممكن من اصدار 2003

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

السلا م عليكم و سمحتو اريد اخفاء الصفوف اذ كانت فارغة او التي يوجد بها صفرمن النطاق c13 الى C65512 وجدت هذا الكود لكنه بطئ جداً يستغرق وقت كبير لاخفاء الصفوف واحيناً يقف الاكسل عن الاستجابة Sub ÇÎÝÇÁ() Application.ScreenUpdating = False For Each cl In Range("c13:cC65512") With cl If .Value = 0 Then .Rows.EntireRow.Hidden = True Else .Rows.EntireRow.Hidden = False End With Next Application.ScreenUpdating = True End Sub الخزينة.rar

استاذ مهند السلام عليكم نصيحة اخوية اجعل موضوعك في مشاركة جديدة حتي لايتشتت القاري للموضو ع ...... ولك الخيار

سوف انتظر شرح الكود كاملاً ..... في وقت فارغك شكراً استاذ ياسر

اقصي جهدي هو هذا وشكراً علي التشيع Sub ReTransferData() ' لتعريف المتغيرات Dim Ws As Worksheet, Sh As Worksheet Dim X, lRow As Integer, LR As Integer 'الصفحة Set Ws = Sheets("ادخال"): Set Sh = Sheets("كشف") 'رقم الخلية التي هي مرجع لرقم الايصال X = Val(Ws.Range("G13").Value) 'تحديد اول سطر فارغ LR = Sh.Cells(Rows.Count, "B").End(xlUp).Row + 1 'لم افهم المتغير xماذا يعني If X <> 0 Then If Application.IsNA(Application.Match(X, Sh.Columns("G:G"), 0)) Then Sh.Range("B" & LR).Resize(1, 10).Value = Ws.Range("B13").Resize(1, 10).Value MsgBox "New Record", 64 Else lRow = Application.Match(X, Sh.Columns("G:G"), 0) Sh.Range("B" & lRow).Resize(1, 10).Value = Ws.Range("B13").Resize(1, 10).Value MsgBox "Editing Exisitng Record At Row " & lRow, 64 End If Else MsgBox "Receipt Number Should Not Be Empty", vbExclamation: Exit Sub End If End Sub

اسف على التاخير في الرد السبب انقطاع التيار الكهربائي استاذ ياسر كمل جميلك ........... واعطينا وظيفة كل سطر من فظلك

كلام كبير ..............

استاذ رجب ماوظيفة هذا السطر 1: Application.CutCopyMode = False

السلام عليكم للتوضيح فقط لقد تسرعت بالحكم على الكود ... بعد نسخ الكود اتضح ان الخطأ في الملف الاصلي ......... والكود يعمل ممتاز شكراً من جديد اريد طلبين لو تكرمت 1/ ما الفرق بين GoTo 1 و اعتقد هنا تقول للكود ايقاف هل هذا صحيح ام لا Exit Sub والطلب الثاني وظيفة كل سطرحتي استخدمة حسب رغبي اكون . Sub ragab() Dim cl As Range, LR As Integer Dim sh As Worksheet, R_N As Integer Set sh = ورقة3 '=========================================== Application.ScreenUpdating = False x = [G13] LR = sh.[G1000].End(xlUp).Row + 1 Range("A13:K13").Copy For Each cl In sh.Range("G13:G" & LR) If cl = x Then R_N = cl.Row sh.Cells(R_N, 1).PasteSpecial xlPasteValues GoTo 1 End If Next sh.Cells(LR, 1).PasteSpecial xlPasteValues 1: Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

التعديل الثاني اظهر لي مشكلة "" الاول ادي الغرض بمتياز .. شكراً استاذ رجب

السلام عليكم بارك الله فيك ... جعله الله لك ذخر في الدنيا والاخرة

السلام عليكم اريد إعادة ترحيل بيانات بعد تعديلها بدون تكررا ......تستبدل بدل البيانات القديمة ترحيل.rar

السلام عليكم تمام التمام استاذ رجب شكراً