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

مرحبا جرب هذا الكود في موديل و اجعل له زر 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 (هذا الكتاب يعد عمل مترجم ولا يعبر عن فكر شخصى إلا فى اجزاء منه)

أخى الفاضل / أبو يوسف ... السلام عليكم هذا حل بسيط إن شاء الله للمطلوب من الملف أجريت بعض التنسيقات اللازمة على ورقة العمل لتبدو على الشكل المطلوب قمت بادخال المعادلات المطلوبة لذلك وشغالة إن شاء الله ـ أدرجت ورقة عمل جديدة باسم ( Mohamed El_Desoky) فيها المطلوب ـ أرجو تجربتها والرد عليها تقبل تحياتى سجل فصل.xlsm ـ محمد الدسوقى.rar

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

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

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

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

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

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

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

لقد جربت الكود على (ويندوز 7 32 بت أوفيس 2007) و اشتغل جيدا .. سأحاول تجريب الكود على أوفيس 2010/2016 لأرى هل المشكلة تحصل في بعض اضدارات الاوفيس

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

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

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

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

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

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

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

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

جرب هذا الكود Private Sub Worksheet_Change(ByVal Target As Range) Dim RB, RF, RJ, RN, My_rg As Range Dim My_sh As Worksheet Dim Oldval, Newval As Long Set My_sh = Sheets("ورقة1") Set RB = Range("b6:b36"): Set RF = Range("f6:f36") Set RJ = Range("j6:j36"): Set RN = Range("n6:n36") Set My_rg = Union(RB, RF, RJ, RN) If Not Intersect(Target, My_rg) Is Nothing And Target.Count = 1 Then With Application .EnableEvents = False .ScreenUpdating = False .Calculation = xlCalculationManual End With Newval = Target.Value Application.Undo Oldval = Target.Value Target.Value = Newval Target.Offset(0, 2) = Target.Offset(0, 2) + Newval End If With Application .EnableEvents = True .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub

الأخ الكريم احمد ديدو السلام عليكم جرب المرفق اللتالى لعلة يفى بالغرض نسألكم الدعاء 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

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

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

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

أخي الحبيب سليم بارك الله فيك وجزاك الله خيراً إثراءً للموضوع هذا حل آخر بالأكواد (رغم أنني لاحظت أن أخونا عبد العزيز يهوى المعادلات أكثر من الأكواد) قم بوضع النصوص المطلوب العمل عليها في الصف الأول A1 و B1 و C1 و D1 إلى آخر النصوص التي تريدها ثم ضع الكود التالي في موديول ونفذ الكود لترى النتائج ، كل نص يليه الحروف المطلوبة كما أوضحت رابط الكود من هنا

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

lمرحبا اخي زياد أنشئ زرا و اكتب الكود التالي Private Sub CommandButton3_Click() Dim MyWorkbook As Workbook, wr As Worksheet, Last As Long Set wr = Sheets("حسابات") Application.ScreenUpdating = False: Application.DisplayAlerts = False Last = wr.Range("E" & Rows.Count).End(xlUp).Row If Last = 4 Then Exit Sub Set MyWorkbook = Workbooks.Add With MyWorkbook wr.Range("E4:G" & Last).Copy .Sheets(1).Range("A1") .ActiveSheet.DrawingObjects.Delete .SaveAs Filename:=ThisWorkbook.Path & "\" & Format(Date, "dd.MM.yy") & ".xlsx" .Close End With Application.ScreenUpdating = True End Sub

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

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

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