نجوم المشاركات

مرحبا جرب هذا الكود في موديل و اجعل له زر Sub sCopyTo() Dim iSh As Worksheet, Sh As Worksheet, MyArray, MySheet, I As Long, R As Long, X As Long Dim Wrd1 As String, Wrd2 As String, Wrd3 As String Set iSh = Sheets("A"): Set Sh = Sheets("y") Wrd1 = "حول": Wrd2 = "معلق": Wrd3 = "معلقة" MyArray = iSh.Range("S10:AB" & iSh.Cells(Rows.Count, 21).End(xlUp).Row).Value ReDim MySheet(1 To UBound(MyArray, 1), 1 To UBound(MyArray, 2)) For I = LBound(MyArray, 1) To UBound(MyArray, 1) If MyArray(I, 1) <> Wrd1 And MyArray(I, 4) <> Wrd2 And MyArray(I, 4) <> Wrd3 Then For X = 3 To 10 MySheet(R + 1, X) = MyArray(I, X) Next X R = R + 1 End If Next I Sh.Range("A10").Resize(R, UBound(MySheet, 2)).Value = MySheet End Sub

عوداً حميداً أخي الكريم أبو حمادة ... الأخ الغالي أبو حنين قدم لنا كود في منتهى منتهى الجمال والروعة .. ومن روعته وجدت نفسي أقوم بوضع شرح لأسطره بارك الله فيك وجزاك الله كل خير على هذه الهدايا القيمة ، وكل عام وأنت بخير عدلت تعديل طفيف للغاية بحيث تكون مصفوفة النتائج تحتوي على النتائج المطلوبة فقط وهي تبدأ من U10:AB وإلى آخر صف عموماً إليكم الكود مع الشرح لجميع أسطر الكود على الرابط التالي رابط الكود مع الشرح من هنا

عفوا خطا بسيط فى البرنامج تم رفعه مجددا الترجمة.rar

السلام عليكم السكرول بعجلة الماوس غير ممكن مع الفورم أو الكنترولات ... الكود التالي يفتح هذه الامكانية وهو كود جامع موحد ملف للتحميل 1- الكود في موديول عاديي Option Explicit Public Enum CTRL_KEY_PRESS_STATE Released Pressed End Enum Public Enum WHEEL_ROTATION Forward Backward End Enum Private Type POINTAPI X As Long Y As Long End Type Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type LongToInteger Low As Integer High As Integer End Type #If VBA7 Then Private Type MSG hwnd As LongPtr message As Long wParam As LongPtr lParam As LongPtr time As Long pt As POINTAPI End Type Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long Private Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr) Private Declare PtrSafe Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (dest As Any, ByVal numBytes As LongPtr) Private Declare PtrSafe Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As LongPtr) As Long #If Win64 Then Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long #Else Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long #End If #Else Private Type MSG hwnd As Long message As Long wParam As Long lParam As Long time As Long pt As POINTAPI End Type Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wCmd 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 GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long Private Declare Function WaitMessage Lib "user32" () As Long Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" (Destination As Any, ByVal Length As Long) Private Declare Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As Long) As Long #End If Private Const CHILDID_SELF = &H0& Private Const S_OK As Long = &H0 Private Const POINTSPERINCH As Long = 72 Private Const LOGPIXELSX As Long = 88 Private Const LOGPIXELSY As Long = 90 Private Const WM_MOUSEWHEEL = &H20A Private Const PM_REMOVE = &H1 Private bCancelProcessing As Boolean Private Const MK_CONTROL = &H8 Private Const SCROLL_CHANGE = 10 Private arObjCaptions() As Variant Private arObjPointers() As Variant Public Sub HookMouseWheelScroll(ByVal UF As Object) Dim WheelRotation As WHEEL_ROTATION Dim CtrlKey As CTRL_KEY_PRESS_STATE Dim tMsg As MSG Dim tCurPos As POINTAPI Dim oIA As IAccessible Dim oObjUnderMouse As Object Dim oPage As Object Dim oCtrl As Object Dim vKid As Variant Dim i As Long Dim j As Long Dim lResult As Long Dim bCancel As Boolean Static k As Long #If VBA7 Then Dim Ptr As LongPtr #Else Dim Ptr As Long #End If bCancelProcessing = False k = 0 UF.Caption = UF.Caption & Chr(10) j = 0 Erase arObjCaptions Erase arObjPointers For Each oCtrl In UF.Controls If TypeName(oCtrl) = "MultiPage" Then For Each oPage In oCtrl.Pages i = i + 1 oPage.Caption = oPage.Caption & String(i, Chr(10)) ReDim Preserve arObjCaptions(j) ReDim Preserve arObjPointers(j) arObjCaptions(j) = oPage.Caption & Chr(10) arObjPointers(j) = ObjPtr(oPage) j = j + 1 Next End If Next Do While Not bCancelProcessing DoEvents GetCursorPos tCurPos #If Win64 Then CopyMemory Ptr, tCurPos, LenB(tCurPos) lResult = AccessibleObjectFromPoint(Ptr, oIA, vKid) #Else lResult = AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, oIA, vKid) #End If If lResult = S_OK Then On Error Resume Next Set oObjUnderMouse = objUnderMouse(UF, oIA, tCurPos) If Not oObjUnderMouse Is Nothing Then WaitMessage If PeekMessage(tMsg, 0, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_REMOVE) Then CtrlKey = IIf(LoWord(CLng(tMsg.wParam)) = MK_CONTROL, Pressed, Released) WheelRotation = IIf(tMsg.wParam > 0, Forward, Backward) Call UF.OnScrollEvent(oObjUnderMouse, WheelRotation, CtrlKey, tMsg.pt.X, tMsg.pt.Y, bCancel) If Not bCancel Then If TypeName(oObjUnderMouse) = "TextBox" Then With oObjUnderMouse .SetFocus If k = 0 Then .SelStart = 0 Else .SelStart = IIf(.SelStart = .LineCount, 0, .SelStart) End If If WheelRotation = Forward Then .CurLine = .CurLine - 1 Else .CurLine = IIf(.CurLine = .LineCount - 1, .CurLine, .CurLine + 1) End If End With k = k + 1 End If If TypeName(oObjUnderMouse) = "ScrollBar" Then With oObjUnderMouse If WheelRotation = Forward Then .Value = IIf(.Value - oObjUnderMouse.SmallChange > .Min, .Value - oObjUnderMouse.SmallChange, .Min) Else .Value = IIf(.Value + oObjUnderMouse.SmallChange < .Max, .Value + oObjUnderMouse.SmallChange, .Max) End If End With End If If TypeName(oObjUnderMouse) = "ListBox" Or TypeName(oObjUnderMouse) = "ComboBox" Then With oObjUnderMouse If CtrlKey = Released Then If WheelRotation = Forward Then .TopIndex = .TopIndex - 1 Else .TopIndex = .TopIndex + 1 End If Else .SetFocus If WheelRotation = Forward Then SendKeys "{LEFT}", True DoEvents SendKeys "{RIGHT}", True Else SendKeys "{RIGHT}", True DoEvents SendKeys "{RIGHT}", True End If End If End With End If If TypeName(oObjUnderMouse) = UF.Name Or TypeName(oObjUnderMouse) = "Frame" Or TypeName(oObjUnderMouse) = "Page" Then With oObjUnderMouse If CtrlKey = Released Then If WheelRotation = Forward Then .ScrollTop = Application.Max(0, .ScrollTop - 5) Else .ScrollTop = Application.Min(.ScrollHeight - .InsideHeight, .ScrollTop + SCROLL_CHANGE) End If Else If WheelRotation = Forward Then .ScrollLeft = Application.Max(0, .ScrollLeft - 5) Else .ScrollLeft = Application.Min(.ScrollWidth - .InsideWidth, .ScrollLeft + SCROLL_CHANGE) End If End If End With End If End If DoEvents End If End If End If Loop End Sub Public Sub RemoveMouseWheelHook() bCancelProcessing = True End Sub 'Private Routines .. '------------------- Private Function objUnderMouse(ByVal UF As Object, ByVal oAcc As IAccessible, MouseLoc As POINTAPI) As Object #If VBA7 Then Dim lngPtr As LongPtr Dim lObjPtr As LongPtr Dim lCtrlPtr As LongPtr Dim hwndForm As LongPtr Dim hwndFromPoint As LongPtr #Else Dim lObjPtr As Long Dim lCtrlPtr As Long Dim hwndForm As Long Dim hwndFromPoint As Long #End If Dim arCtrlsPosition() As Variant Dim arCtrlsPointers() As Variant Dim tPt As POINTAPI Dim tRect As RECT Dim oObj As Object Dim oCtrl As Control Dim sBuffer As String Dim lCtrlLeft As Long Dim lCtrlTop As Long Dim lPos1 As Long Dim lPos2 As Long Dim lPos3 As Long Dim lRet As Long Dim i As Long On Error Resume Next hwndForm = FindWindow(vbNullString, UF.Caption) For Each oCtrl In UF.Controls ReDim Preserve arCtrlsPosition(i + 1) ReDim Preserve arCtrlsPointers(i + 1) tPt = GetRealCtrlScreenLocation(oCtrl, hwndForm, UF) arCtrlsPosition(i) = tPt.X & tPt.Y arCtrlsPointers(i) = ObjPtr(oCtrl) arCtrlsPosition(i + 1) = tPt.X - 2 & tPt.Y - 1 arCtrlsPointers(i + 1) = ObjPtr(oCtrl) i = i + 2 Next lPos1 = WorksheetFunction.Match(oAcc.accName(CHILDID_SELF) & Chr(10), arObjCaptions, 0) lObjPtr = WorksheetFunction.Index(arObjPointers, 1, lPos1) Call oAcc.accLocation(lCtrlLeft, lCtrlTop, 0, 0, CHILDID_SELF) lPos2 = WorksheetFunction.Match(lCtrlLeft & lCtrlTop, arCtrlsPosition, 0) lCtrlPtr = WorksheetFunction.Index(arCtrlsPointers, 1, lPos2) #If VBA7 Then CopyMemory lngPtr, MouseLoc, LenB(MouseLoc) hwndFromPoint = WindowFromPoint(lngPtr) #Else hwndFromPoint = WindowFromPoint(MouseLoc.X, MouseLoc.Y) #End If sBuffer = Space(256) lRet = GetClassName(GetParent(hwndFromPoint), sBuffer, 256) lPos3 = InStr(1, Left(sBuffer, lRet), "MdcPopup") Select Case True Case lPos3 <> 0 Set objUnderMouse = GetActiveComboBox(UF) Exit Function Case oAcc.accName(CHILDID_SELF) = UF.Caption Set oObj = UF Case lObjPtr = 0 If IsBadCodePtr(lCtrlPtr) = 0 Then CopyMemory oObj, lCtrlPtr, 4 End If Case lObjPtr <> 0 If IsBadCodePtr(lObjPtr) = 0 Then CopyMemory oObj, lObjPtr, 4 End If End Select Set objUnderMouse = oObj If Not oObj Is Nothing Then ZeroMemory oObj, 4 End If End Function #If VBA7 Then Private Function GetRealCtrlScreenLocation(ByVal Ctl As Object, ByVal hwnd As LongPtr, ByVal UF As Object) As POINTAPI #Else Private Function GetRealCtrlScreenLocation(ByVal Ctl As Object, ByVal hwnd As Long, ByVal UF As Object) As POINTAPI #End If Dim tRect As RECT Dim tTopLeft As POINTAPI Dim oMultiPage As Control Dim oTempObj As Control On Error Resume Next Set oTempObj = Ctl.Parent With tTopLeft Select Case True Case oTempObj Is Nothing .X = PTtoPX(Ctl.Left - UF.ScrollLeft * UF.Zoom / 100, False) .Y = PTtoPX(Ctl.Top - UF.ScrollTop * UF.Zoom / 100, True) ClientToScreen hwnd, tTopLeft Case TypeName(oTempObj) = "Frame" GetWindowRect oTempObj.[_GethWnd], tRect .X = PTtoPX(Ctl.Left - oTempObj.ScrollLeft * (oTempObj.Zoom / 100), False) + tRect.Left + 2 .Y = PTtoPX(Ctl.Top - oTempObj.ScrollTop * (oTempObj.Zoom / 100), True) + tRect.Top + 8 Case TypeName(oTempObj) = "Page" Set oMultiPage = oTempObj.Parent GetWindowRect GetNextWindow(oMultiPage.[_GethWnd], 5), tRect .X = PTtoPX(Ctl.Left - oTempObj.ScrollLeft * (oTempObj.Zoom / 100), False) + tRect.Left .Y = PTtoPX(Ctl.Top - oTempObj.ScrollTop * (oTempObj.Zoom / 100), True) + tRect.Top Set oMultiPage = Nothing End Select End With GetRealCtrlScreenLocation = tTopLeft Set oTempObj = Nothing End Function Private Function GetActiveComboBox(ByVal Ctl As Object) As Control Dim oCtl As Object Dim lCur As Long On Error Resume Next For Each oCtl In Ctl.Controls Err.Clear lCur = oCtl.CurX If Err.Number = 0 And TypeName(oCtl) = "ComboBox" Then Set GetActiveComboBox = oCtl: Exit Function Next End Function Private Function LoWord(ByVal Word As Long) As Integer Dim X As LongToInteger CopyMemory X, Word, LenB(X) LoWord = X.Low End Function Private Function ScreenDPI(ByVal bVert As Boolean) As Long Static lDPI(1), lDC If lDPI(0) = 0 Then lDC = GetDC(0) lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX) lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY) lDC = ReleaseDC(0, lDC) End If ScreenDPI = lDPI(Abs(bVert)) End Function Private Function PTtoPX(ByVal Points As Single, ByVal bVert As Boolean) As Long PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH End Function 2- كود في موديول الفورم Option Explicit Private Sub UserForm_Activate() Dim i As Long 'Populate the controls For i = 0 To 100 With ListBox1 .ColumnCount = 4 .ColumnWidths = "100;100;100;100" .AddItem "COLUMN1" .List(i, 1) = "COLUMN2" .List(i, 2) = "COLUMN3" .List(i, 3) = "COLUMN4" End With ListBox2.AddItem i ComboBox1.AddItem i ComboBox2.AddItem i ComboBox3.AddItem i ComboBox4.AddItem i ComboBox5.AddItem i ComboBox6.AddItem i ComboBox7.AddItem i ComboBox8.AddItem i ComboBox9.AddItem i Next i With TextBox1 .Text = .Text & String(300, "A") .Text = .Text & String(300, "I") .Text = .Text & String(300, "X") End With Label1.Caption = "Object :" Label2.Caption = "Wheel Rotation :" Label3.Caption = "Scroll Direction :" Label4.Caption = "Cursor X :" Label5.Caption = "Cursor Y :" Label6.Caption = "Scroll Cancelled :" 'Hook MouseWheel Scroll of Form and of all its controls Call HookMouseWheelScroll(Me) End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Call RemoveMouseWheelHook End Sub Private Sub CommandButton1_Click() Unload Me End Sub '-------------------- 'Public Generic event '-------------------- Public Sub OnScrollEvent(ByVal Obj As Object, ByVal WheelRotation As WHEEL_ROTATION, _ ByVal CtrlKey As CTRL_KEY_PRESS_STATE, ByVal X As Long, ByVal Y As Long, Cancel As Boolean) Dim sObjName As String, sWheelRot As String, sCtrlKey As String Dim sCurX As String, sCurY As String, sCancelScrol As String sObjName = "Object : (" & Obj.Name & ")" sWheelRot = "Wheel Rotation : (" & IIf(WheelRotation = Forward, "Forward", "Backward") & ")" sCtrlKey = "Scroll Direction : (" & IIf(CtrlKey = Released, "Vert", "Horiz") & ")" sCurX = "Cursor X : (" & X & ")" sCurY = "Cursor Y : (" & Y & ")" sCancelScrol = "Scroll Cancelled : (" & Cancel & ")" Label1.Caption = sObjName Label2.Caption = sWheelRot Label3.Caption = sCtrlKey Label4.Caption = sCurX Label5.Caption = sCurY Label6.Caption = sCancelScrol End Sub

يكون بهذه الطريقة Private Sub UserForm_Activate() Dim ws As Worksheet For Each ws In ThisWorkbook.Sheets If ws.Name <> "5" Then Me.ComboBox1.AddItem ws.Name Next End Sub

شكرا لك وكل عام وانتم بخير تعقيب بسيط اخى الكريم اذا كان هناك مليار مسلم على وجه هذه الارض منهم 500 مليون يحملون اسماء بالعربية ف اى عقل ساجده ليجعلنى اكتب ال 500 مليون اسم ثم اكتب ما يقابله بالانجليزية ؟؟؟ اخى الكريم شكرا لك على مشاركتك وكل عام وانتم بخير تعقيب بسيط خير وسيلة للتعلم هو الا تكون مجرد الة ناقلة للاكواد واسال نفسك كثيرا اذا اردت التعلم ( لماذا ؟؟ لا كيف ؟؟) والا ستظل تبحث وتبحث وتقتل موهبتك التى بداخلك فى حب البرمجة كان من الممكن ان تاخذه هذه الوحدةة النمطية وتضعها فى استعلام خاص بالجدول وانتهى الامر لكنك فقط تريد وتريد وتريد تعالى بقى انت يا برنس يللى فاهمنى شكرا لك اولا على ردك وكل عام وانتم بخير اخوانى الذين علقوا قبلك تناسوا امران مهمان وهما 1 - انى ذكرت ان البرنامج يترجم ترجمة حرفية فمن الطبيعى ان يجدوا اسمائهم ناقصة 2- الامر الثانى بخلاف مشكلة اسم طارق الذى ترجم الى Tarf فقط خطا بسيط فى كتابة كود رمز حرف ال k ولكن لو لاحظت عند كتابة الاسماء مثلا محمد عصام وجد ناقصا لان اغل الحروف الناقصة ستكون حروف متحركة يعنى a / e / i / وهكذا يمكن حل ذلك بواسطة التشكيل فلو قمنا بتشكيل الاسم ستجد الاسم كتب كاملا ولقد اجلت موضوع التشكيل لتجربة مرفق التحديث وسيكون فى الاصدار الجديد للبرنامج مرة اخرى شكرا لكم جميعا

أخي الكريم عادل .. سأقوم إن شاء الله عزوجل بشرح الكود على مراحل (كلما تيسر لي الوقت) ، لأنني أريد شرح الكود بشيء من التفصيل ، وليس الهدف من شرح الكود هو الشرح وفقط ، بل الهدف الأكبر هو أن تتعلم كيفية متابعة تنفيذ الكود سطر بسطر إليك الجزء الأول من الشرح .. اتبع الخطوات جيداً وكررها أكثر من مرة لتتدرب عليها ولتتعلم أساسيات التعامل مع الأكواد ******************************************** ******************************************** ********************************************

العفو هناك تعديل بسيط Private Sub CommandButton1_Click() Dim Rng As Range, M As Long, sh As Worksheet, last As Long Set sh = Sheets("حسابات") last = sh.Cells(sh.Rows.Count, 2).End(xlUp).Row Set Rng = sh.Range("b4:b" & last) If Not IsDate(TextBox1) Or TextBox1 = "" Then GoTo 100 On Error Resume Next M = Rng.Cells.Find(CDate(TextBox1), LookAt:=xlWhole, MatchCase:=True).Activate TextBox4.Value = sh.Range(ActiveCell.Address).Offset(, 8) 100 TextBox2.Value = WorksheetFunction.SumIf(sh.Range("a4:a" & last), 8, sh.Range("j4:j" & last)) End Sub هل اكتشفت موقع الخطأ جرب ان تترك مربع النص الخاص بالتاريخ فارغا في الكود الاول ستكتشف الخطأ السبب هو موقع السطر التالي If Not IsDate(TextBox1) Or TextBox1 = "" Then GoTo 100 يجب ان يكون بعد تعريف المتغيرين : sh و Last

الفكرة جميلة بس لى تعقيب صغير جدا لو كتبت محمد عصام بتترجم الى mhmd asam فى حين انها تكون mohammed essam اعتقد الافضل ان تكون الاسماء وما يقابلها بدلا من الحروف وما يقابلها دى فكرة برضوا لكنها ستكون مرهقة ممكن نجعل المستخدم فى بادئ الامر يكتب الاسم العربى ثم الترجمه الى الانجليزية ومع التكرار اذا كتب الاسم بالعربى يترجم الى الانجليزية مباشرة من ما تم حفظه من قبل

الأستاذ الفاضل / ابو حماده السلام عليكم ورحمة الله وبركاته حل رائع وممتاز الذى قدمه أخى الفاضل / أبو حنين ـ زاده الله من علمه النافع وجعله فى ميزان حسناته وأقدم لك حل متواضع آخر باستخدام المعادلات حيث تقوم بالترحيل تلقائيا ـ ويمكن ترحيل الأسماء كما طلبت بعد استبعاد المحولين والمعلقين ــ كما يمكن ترحيل الأسماء المستبعدة فقط بعد اختيار المطلوب من القائمة أعلى الصفحة وتقبل تحياتى ترحيل 2ـ بالمعادلات.rar

وعليكم السلام أخي الكريم حسين55 يرجى تغيير رقم 55 للقبك إذا كان بالإمكان في المرفق وجدت مصنفين أحدهما باسم Aman والآخر باسم أصناف1 ، ولاحظت أن مصنف أصناف بامتداد xlsb ، والآخر بامتداد xlsx .. لذا : قم بوضع الكود التالي في مصنف "أصناف1" .. افتح المصنف أصناف1 ، وادخل لمحرر الأكواد ، وأدرج موديول جديد ، وضع الكود في الموديول الجديد ، ثم أغلق محرر الأكواد (ولا تغلق المصنف أصناف1) ثم اذهب للمصنف المسمى Aman وقم بفتحه .. الآن قم بالضغط على Alt + F8 لتنفيذ الكود (الإجراء الفرعي المسمى Compare_Two_Open_WBs) رابط الكود من هنا تقبل تحياتي

السلام عليكم ورحمة الله وددت أن أشارك بهذا الملف المرفق.... بن علية تقسيم الكلمة hben.rar

كل عام و انتم بخير و ايام مباركه

كل عام وأنتم بخير إخواني وأحبابي في الله أعاده الله علينا باليمن والأمن والخير والبركات .. تقبل الله منا ومنكم صالح الأعمال

جرب هذا الملف (Sheet2) تقسيم الكلمة salim.rar

وعسى الجنة مثواكم

تهنئة قلبية بقرب حلول عيد الأضحى المبارك إلى كل عضو كريم في منتدانا العريق أوفيسنا نرجو الله أن يعيده على الأمة الإسلامية جمعاء بالخير واليمن والبركة

كل عام وانت بخير اخي الكريم جلال وكل عام وجميع الامة الاسلامية بخير

السلام عليكم ورحمة الله وبركاته الحمد لله والصلاة والسلام على رسول الله وعلى اله واصحابه اجمعين. ========================================================================================================================= اليكم ملف اكسيل حسابات عامه من قيود اليومية وحتى الميزانيه لشركات المقاولات -مع انى لم اعمل فى نشاط المقاولات -بشكل خاص وجميع الانشطة بشكل عام مع تعديل دليل الحسابات . وهذا الملف ربما سيكون الاخير لى فى 2014 نظرا لضغوط العمل . واطلب من الجميع الا ينسانى فى دعاؤه . باسوورد محرر الاكواد 12345 وايضا باسورد الحمايه للمعادلات . اصدار الاوفيس من 2007 وحتى اخر اصدار . ========================================================================================================================= ماعليك الا ادخال قيد اليومية فقط والضغط على زر الترحيل ========================================================================================================================= استخدمت فى البرنامج الاكواد والمعادلات والpivottable واشكال بيانيه فى التنسيقات الشرطيه وادمجت معادلات فى الاشكال البيانيه ========================================================================================================================= لاتنسونا بصالح دعاؤكم ملف المقاولات الاصدار الاول تجريبى.rar

السلام عليكم ورحمة الله وبركاته إخواني الكرام ..أحبابي في الله أقدم لكم اليوم كودين ، تعتمد الفكرة فيهما على تجميع القيم التي يتم إدخالها ، مع كل إدخال جديد في المرفق ستجد ملفين .. الملف الأول باسم Single Cell Accumulator أي التجميع للقيم في خلية واحدة فقط ويظهر الناتج في نفس الخلية .. قم بإدخال أي قيمة في الخلية A1 وليكن 5 ثم سهم لأسفل واكتب القيمة 4 ستجد أن ناتج الخلية أصبح 9 ، اكتب 3 ثم سهم لأسفل ستجد الناتج أصبح 12 وهكذا .. أعتقد أن فكرة الكود قد وصلتكم الآن .. لإعادة ضبط عملية التجميع قم بمسح محتويات الخلية A1 أو وضع نص بها .. الكود في الملف الأول بهذا الشكل (في حدث ورقة العمل) Private Sub Worksheet_Change(ByVal Target As Excel.Range) Static dAccumulator As Double With Target If .Address(False, False) = "A1" Then If Not IsEmpty(.Value) And IsNumeric(.Value) Then dAccumulator = dAccumulator + .Value Else dAccumulator = 0 End If Application.EnableEvents = False .Value = dAccumulator .Select Application.EnableEvents = True End If End With End Sub الملف الثاني باسم Two Cell Accumulator وفي هذا الملف تتم عملية الإدخال في الخلية A1 بينما تظهر النتائج في الخلية B1 ، ففي كل إدخال رقمي يتم تجميع القيمة إلى القيمة الموجودة في الخلية A1 ، وهنا إذا تم مسح محتويات الخلية A1 أو كتابة نص بها ، فإن الناتج في الخلية B1 يظل كما هو ، ولإعادة ضبط عملية التجميع من جديد قم بمسح محتويات الخلية B1 والكود في الملف الثاني يظهر بهذا الشكل (في حدث ورقة العمل) Private Sub Worksheet_Change(ByVal Target As Excel.Range) With Target If .Address(False, False) = "A1" Then If IsNumeric(.Value) Then Application.EnableEvents = False Range("B1").Value = Range("B1").Value + .Value Application.EnableEvents = True .Select End If End If End With End Sub أرجو من الله أن يجعل أعمالنا صالحة ، ولوجهه خالصة .. دمتم في رعاية الله حمل الملف من هنا

http://im40.gulfup.com/Ltirv.jpg هذا الكتاب يعد اول كتاب باللغه العربية لتعلم لغه ال VBA http://im35.gulfup.com/saxzs.png يتناول الكتاب ما يلى:- ❑ تخزين المعلومات في المتغيرات والمصفوفات ❑ صنع القرار في التعليمات البرمجية ❑ الحلقات ❑ معالجة الأخطاء ❑ اليوزر فورم رابط التحميل http://www.mediafire.com/download/dj01xxwnczia62k/VBA+Excel.rar (هذا الكتاب يعد عمل مترجم ولا يعبر عن فكر شخصى إلا فى اجزاء منه)

السلام عليكم ورحمة الله تعالى وبركاته كل عام وانتم الى الله اقرب عيد اضحى مبارك هذا التصميم الفلاشى فى هذا الرابط اهداء منى الى كل احبابى واخوانى فى منتديات اوفيسنا اسال الله تعالى ان يعيد عليكم تلك الايام الطيبات الطاهرات المباركات وانتم تنعمون بالصحة والسعادة والهناء اسال الله تعالى ان يرزقنى واياكم فضلك العشر ايام المباركات ان شاء الله ☺ http://store1.up-00.com/2016-09/147276120351.swf

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

هو لو الكود في حدث ورقة العمل ومسحت الخلية هيتم التصفير بشكل تلقائي راجع شرح الموضوع وطبق الموضوع كويس وحاول تفهم الطريقة ، وإن شاء الله تقدر تطبقها على ملفك .. وبعتذر إني مش بقدم حلول كاملة لضيق الوقت ليس إلا .. لأني في خلال ساعات قليلة سأغادر لأرض الأهل والوطن ..

1- اجعل لون الليست بوكس بلون اليوزر قور 2- خيار SPECTIAL EFFECT اجعله FLAT وهذه حيلة ممكن تنفع وممكن لأ

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

بعد وضع الكود لا تفعل شيئاً فقط غير اي رقم في اي عامود B,F,j او N عند الضغط على الخلية A1 يتم تصفير كل شيء (ماكرو الاخ ابو عبد الباري) و عند تغيير اي خلية في الاعمدة(B,F,j او N ) ابتداء من الصف السادس الى 36 يتم الجمع الى الخلية المجاورة جرب هذا المرفق tazkara.rar

السلام عليكم و رحمة الله مرحبا بكم فى موعد أدعو الله أن يعيننى على استكماله مع كثرة و تجدد المشاغل ليبقى زخرا للمبتدئين و الغيرهم فى شروح الأكسيس اليوم موعدنا مع فيديو للمبتدئين عن استعلام التحديد و هو أكثر أنواع الاستعلامات شيوعا و استخداما ما هى صوره و كيف نحدد الشروط فيه حسب أنواع الحقول و كيف تجعله مصدرا لستقرير مطبوع أرجو أن تنتفعوا به و قمت برفع ملف الأكسيس المستخدم فى الشرح هنا https://drive.google.com/file/d/0Bw4...ew?usp=sharing وفقكم الله

و عليكم السلام و رحمة الله و بركاته اخي العزيز جمال وضع مثال من طرفك يسهل على الجميع الحل .. جرب وضع التعبير التالي في معيار الاستعلام Is Not Null قد يكون هو المطلوب بالتوفيق

الأخ الكريم احمد ديدو السلام عليكم جرب المرفق اللتالى لعلة يفى بالغرض نسألكم الدعاء abo_abary_تذكرة.rar

مرحبا بعد اذن اخي ياسر ضع الكود التالي في زر Private Sub CommandButton1_Click() Dim Rng As Range, M As Long, sh As Worksheet, last As Long If Not IsDate(TextBox1) Or TextBox1 = "" Then GoTo 100 Set sh = Sheets("حسابات") last = sh.Cells(sh.Rows.Count, 2).End(xlUp).Row Set Rng = sh.Range("b4:b" & last) On Error Resume Next M = Rng.Cells.Find(CDate(TextBox1), LookAt:=xlWhole, MatchCase:=True).Activate TextBox4.Value = sh.Range(ActiveCell.Address).Offset(, 8) 100 TextBox2.Value = WorksheetFunction.SumIf(sh.Range("a4:a" & last), 8, sh.Range("j4:j" & last)) End Sub

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

ما شاء الله عليكم يا استاذ ياسر شرح وافى كافى زادك الله من علمه وفضله واحسانه

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

احلى واغلى تحية لهذا الصرح العظيم وكل عام وانتم بخير وهذا المنتدى فى تقدم وازدهار

أخي أبو يوسف حاول أن تساعدنا بوضع التصميم المطلوب وضع شكل النتائج المتوقعة كدليل لنا .. حتى نستطيع تقديم المساعدة الملف ملفك والتصميم والمخرجات تخصك (فقط حاول ألا تستخدم الخلايا المدمجة قدر الإمكان)

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

يمكنك تغيير مسار الحفظ من هذا السطر أخي زياد777 (مش هنساك) .SaveAs Filename:=ThisWorkbook.Path & "\" & Format(Date, "dd.MM.yy") & ".xlsx" يمكنك إزالة ThisWorkbook.Path ووضع مسارك المطلوب بين أقواس تنصيص .. مثال : "D:\Zeyad" حيث Zeyad هو اسم المجلد الموجود على البارتشن D

السلام عليكم أخي محمد ايمن برأيي بما أنه هو سيقوم باغلاق البرامج على كل الاجهزة فهذا يعني ان الاجهزة فارغة لا تستخدم والسؤال الذي لا يجيب عليه الا صاحب المشاركة لماذا لا يغلق البرنامج من كان يستخدمه قبل المغادرة حدث ذلك معي قبل مرة ولكن بشكل مختلف وهو أنه يجب ان يغلق الكمبيوتر في الساعة 9:00 ليلا وانا انهي عملي في الساعة 7:00 مساءا لان جهازي هو السيرفر واغلاقه يقطع اتصال الشبكة عن باقي الاجهزة فاستخدمت وقتها برنامج يقوم باطفاء الجهاز في الوقت المناسب أما بشان التنبيه فهناك حل بان تكون رسالة التنبيه لها زمن ما ان انتهى الزمن يتم الاغلاق ما لم يلغى امر التنبيه

وعليكم السلام أخي أبو حمادة يرجى مراجعة التوجيهات .. من الأفضل تناول نقطة واحدة في الموضوع لكي تجد استجابة أفضل كما يجب أن توضح شكل النتائج المتوقعة .. وتكلم بلغة الإكسيل : كأن تقول في ورقة كذا في العمود كذا يوجد في الخلية كذا لاحظ الموضوع مر عليه 15 ساعة بدون ولا رد .. صدقني الأفضل لك أن تطرح موضوع مستقل لكل طلب فهذا أيسر للجميع تقبل تحياتي

أحسنتم الاختيار فنعم الناس الاستاذ سليم

الاخ سليم حاصبيا انك انسان مؤدب هذه هي القواعد القديمة التي نفتقدها

أخي الكريم خالد حملت الملف وعند الفتح استغرق وقتاً طويلاً جداً ...في الفتح ، وعلى ما يبدو أن التعامل مع الملف سيكون صعب لذا أنصح بعمل ملف تضع فيه الشكل العام للبيانات بدون معادلات وبدون أكواد ..ملف جديد وتوضح فيه المطلوب بشيء من التفصيل .. ولا تجعل التفاصيل في الملف نفسه بل اجعله في المشاركة للإطلاع عليها قبل الإطلاع على الملف المرفق الملف ما زال يحاول الفتح ... سيكون صعب جداً التعامل معه بهذا الشكل ..

تهنئة قلبية بقرب حلول عيد الأضحى المبارك إلى كل عضو كريم في منتدانا العريق أوفيسنا نرجو الله أن يعيده على الأمة الإسلامية جمعاء بالخير واليمن والبركة

كل عام و انتم بخير

أخي الكريم عمر أحمد أهلاً بك في المنتدى ونورت بين إخوانك يبدو أنك التحقت بالمنتدى لأجل هذا البرنامج .. للأسف يبدو أن الرابط به مشكلة ، ولحسن الحظ أنني أحتفظ بهذا الملف في مكتبتي الخاصة إليك الملف على الرابط التالي رابط برنامج شئون الطلبة من هنا

شغلة بسيطة تبديل اول حرفين.rar او ربما هذه المعادلة هي الانسب =IF($A1="","",MID($A1,2,LEN($A1)-1)&MID($A1,1,1))

ديدو نازل أسئلة في كل حاجة في موضوع واحد .. ممكن نسميه الموضوع الجامع لكل استفسارات أحمد ديدو ... راجع التوجيهات وخلي كل سؤال بموضوع مستقل ، مع استيفاء الشروط من إرفاق ملف وتوضيح تام للطلب ..

السلام عليكم كذلك ابدي اعجابي بالسؤال وبيشغل البطيخة على مقولة الاستاذة زهرة واعتقد انه لم يمر على المنتديات العربية هذه محاولة مع الاستاذ يوسف والفكرة فكرة ترتيب فتم اضافة حقل للترتيب فقط في جدول main بالتوفيق ترتيب سجلات.rar

السلام عليكم ورحمة الله جزاكم الله كل خير استاذنا خبور خير ولإثرا الموضوع المعادلة التالية تجمع الجمل التي تبدأ بكلمة محمد =SUMPRODUCT((LEFT(A1:A7;4)="محمد")*(B1:B7);(C1:C7)) المعادلة التالية تجمع الجمل التي تبدأ او تحتوي على كلمة محمد =SUMPRODUCT((ISERROR(SEARCH("محمد";A1:A7;1))=FALSE)*(B1:B7);(C1:C7)) تحياتي