الـعيدروس

====================== هذا الكود لا لي فيه لاناقة ولا جمل هذا الكود من ابداعات الاستاذ الكبير جعفر ======================

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

جرب المرفق عله يكون المطلوب GAFAR_F_ALL.rar

لاعدمناك استاذ محمد صالح الحمد لله انك لم تشف ردي كنا سنفقد معلومه

طلبك رخيص تفضل المرفق ALIDROOS_JC_1.rar

تفضل For T = 1 To 12 Me.Controls("TEXTBOX" & T).Value = Empty Next T TextBox101.Value = "" For C = 2 To 12 Me.Controls("COMBOBOX" & C).Value = Empty Next C

وش رأيك نخلية ( أبو نضال) بيكون لقب حماسي هذا المرفق وفيه الكود جرب اكتب قيمة صفر في احد خلايا I9 او H9 ولاحظ GAFAR_F.rar

الاخ الفاضل ابو الحسن اشكرك على هذا المرور العطر وانت مميز بردودك وفقك الله وهذا الكود المستخدم Sub ALI() Dim ALI_R As Range, A As Range Dim S As Worksheet, S1 As Worksheet Application.ScreenUpdating = False Dim ALI As Long Set S = Sheets("Sheet1"): Set S1 = Sheets("Sheet2") Set A = S1.Range("A2") Set Z = S1.Range("A8:A5000") ALI1 = ورقة2.Range("A15000").End(xlUp).Row + 1 S.Select Set ALI_R = S.Range("A2:A5000").Find(what:=A, lookat:=xlWhole) If Not ALI_R Is Nothing Then For T = 7 To 5000 If Application.WorksheetFunction.CountIf(S1.Range("A2"), S1.Cells(T, 1)) = 1 Then MsgBox "السجل موجود", vbCritical, "تنبية !!!": S1.Select: Exit Sub Next T ALI_R.Resize(1, 6).Copy ورقة2.Select ورقة2.Range("A" & ALI1).PasteSpecial xlPasteValues Application.CutCopyMode = False Else MsgBox "هذا الكود غير موجود في قادة البيانات", vbInformation, "تنبية !!!" Exit Sub End If Application.ScreenUpdating = True End Sub

السلام عليكم جرب المرفق زر كود_ALI.rar

السلام عليكم جرب المرفق واي ملاحظات انا موجود تحياتي ALIDROOS_JC.rar

السلام عليكم هذا كود للاستاذ الحبيب جعفر وتم عمل تعديل بسيط ليتناسب مع طلبك حط هذا الكود في حدث الصفحة Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("i9:h9")) Is Nothing Then Select Case Target Case Is <= 0 Call StartPulsating Case Else Call StopPulsating End Select End If End Sub وحط هذا الكود في مودويل Option Explicit 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 Declare Function FindWindow Lib "user32.dll" _ Alias "FindWindowA" _ (ByVal lpClassName As String, _ ByVal lpWindowName As String) As Long Private Declare Function FindWindowEx Lib "user32.dll" _ Alias "FindWindowExA" _ (ByVal hWnd1 As Long, _ ByVal hWnd2 As Long, _ ByVal lpsz1 As String, _ ByVal lpsz2 As String) As Long 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 ReleaseDC Lib "user32" ( _ ByVal hwnd As Long, _ ByVal hdc As Long) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" _ (ByVal hdc As Long) As Long Private Declare Function CreateCompatibleBitmap Lib "gdi32" _ (ByVal hdc As Long, _ ByVal nWidth As Long, _ ByVal nHeight As Long) As Long Private Declare Function SelectObject Lib "gdi32" _ (ByVal hdc As Long, _ ByVal hObject As Long) As Long Private Declare Function DeleteObject Lib "gdi32" _ (ByVal hObject As Long) As Long Private Declare Function BitBlt Lib "gdi32" _ (ByVal hDestDC As Long, _ ByVal x As Long, _ ByVal y As Long, _ ByVal nWidth As Long, _ ByVal nHeight As Long, _ ByVal hSrcDC As Long, _ ByVal xSrc As Long, _ ByVal ySrc As Long, _ ByVal dwRop As Long) As Long Private Declare Function StretchBlt Lib "gdi32" _ (ByVal hdc As Long, _ ByVal x As Long, _ ByVal y As Long, _ ByVal nWidth As Long, _ ByVal nHeight As Long, _ ByVal hSrcDC As Long, _ ByVal xSrc As Long, _ ByVal ySrc As Long, _ ByVal nSrcWidth As Long, _ ByVal nSrcHeight As Long, _ ByVal dwRop As Long) As Long Private Declare Function InvalidateRect Lib "user32.dll" _ (ByVal hwnd As Long, _ ByVal lpRect As Long, _ ByVal bErase As Long) As Long Private Declare Function RedrawWindow Lib "user32" _ (ByVal hwnd As Long, _ ByVal lprcUpdate As Long, _ ByVal hrgnUpdate As Long, _ ByVal fuRedraw As Long) As Long Private Declare Function ScreenToClient Lib "user32" ( _ ByVal hwnd As Long, _ lpPoint As POINTAPI) As Long Private Declare Function SetRect Lib "user32.dll" _ (ByRef lpRect As RECT, _ ByVal X1 As Long, _ ByVal Y1 As Long, _ ByVal X2 As Long, _ ByVal Y2 As Long) As Long Private Declare Function CreateRectRgn Lib "gdi32.dll" _ (ByVal X1 As Long, _ ByVal Y1 As Long, _ ByVal X2 As Long, _ ByVal Y2 As Long) As Long Private Declare Function PlaySoundAPI Lib "winmm.dll" _ Alias "PlaySoundA" _ (ByVal lpszName As String, _ ByVal hModule As Long, _ ByVal dwFlags As Long) As Long Private Declare Function SetTimer Lib "user32.dll" _ (ByVal hwnd As Long, _ ByVal nIDEvent As Long, _ ByVal uElapse As Long, _ ByVal lpTimerFunc As Long) As Long Private Declare Function KillTimer Lib "user32.dll" _ (ByVal hwnd As Long, _ ByVal nIDEvent As Long) As Long Private Const SRCCOPY As Long = &HCC0020 Private Const LOGPIXELSX As Long = 88 Private Const LOGPIXELSY As Long = 90 Private Const RDW_INVALIDATE As Long = &H1 Private Const RDW_ALLCHILDREN As Long = &H80 Private Const SND_ASYNC As Long = &H1 Private Const SND_FILENAME As Long = &H20000 Private Const SND_LOOP As Long = &H8 Private Const CYCLE As Long = 40 Private Const POINTSPERINCH As Long = 72 Private Const SOUNDFILEPATHNAME As String = _ "C:\WINDOWS\MEDIA\chimes.WAV" 'change sound file as required. Private tRect As RECT Private tUpdateRect As RECT Private lWBHwnd As Long Private lMemoryDC As Long Private lInterval As Long Private oPulsatingRange As Range Private vInitialRangeVal As Variant Private bPlayBeep As Boolean Sub StartPulsating() Dim T As Range, C As Range Set T = Sheets(1).Range("I9") Set C = Sheets(1).Range("H9") If T <= 0 Then PulsateRange Target:=T, PlaySound:=True Exit Sub Else If C <= 0 Then PulsateRange Target:=C, PlaySound:=True Exit Sub End If End If End Sub Private Sub PulsateRange(ByVal Target As Range, Optional ByVal PlaySound As Boolean) Dim lXLDeskhwnd As Long vInitialRangeVal = Target lInterval = 0 Set oPulsatingRange = Target lXLDeskhwnd = FindWindowEx(FindWindow("XLMAIN", Application.Caption) _ , 0, "XLDESK", vbNullString) lWBHwnd = FindWindowEx _ (lXLDeskhwnd, 0, "EXCEL7", vbNullString) If PlaySound Then If Len(Dir(SOUNDFILEPATHNAME)) <> 0 Then PlaySoundAPI SOUNDFILEPATHNAME, _ ByVal 0&, SND_FILENAME Or SND_ASYNC Or SND_LOOP Else bPlayBeep = True End If End If Call TakeRangeSnapShot(ByVal oPulsatingRange) End Sub Sub StopPulsating() KillTimer lWBHwnd, 0 InvalidateRect 0, 0, 0 PlaySoundAPI vbNullString, 0, 0 bPlayBeep = False lInterval = 0 End Sub Private Sub TakeRangeSnapShot(ByVal Target As Range) Dim lDC As Long lInterval = 0 lDC = GetDC(lWBHwnd) With GetRangeRect(ByVal Target) Call GetRngBmpHandle(lDC, .Left, .Top, _ (.Right - .Left), (.Bottom - .Top)) SetRect tRect, .Left, .Top, .Right, .Bottom End With ReleaseDC 0, lDC SetTimer lWBHwnd, 0, 1, AddressOf TimerProc1 End Sub Private Sub TimerProc1() Dim lDC As Long Dim lhRng As Long On Error Resume Next If Not ActiveSheet Is oPulsatingRange.Parent Then Exit Sub lDC = GetDC(lWBHwnd) If (GetRangeRect(ByVal oPulsatingRange).Right <> tRect.Right _ Or GetRangeRect(ByVal oPulsatingRange).Top <> tRect.Top) Or _ vInitialRangeVal <> oPulsatingRange.Value Then InvalidateRect 0, 0, 0 tRect.Right = GetRangeRect(ByVal oPulsatingRange).Right tRect.Top = GetRangeRect(ByVal oPulsatingRange).Top vInitialRangeVal = oPulsatingRange.Value KillTimer lWBHwnd, 0 SetTimer lWBHwnd, 0, 1, AddressOf TimerProc2 ReleaseDC 0, lDC Exit Sub End If With tRect If lInterval < (CYCLE / 2) Then StretchBlt _ lDC, .Left - lInterval, .Top - lInterval, _ (.Right - .Left) + 2 * lInterval, _ (.Bottom - .Top) + 2 * lInterval, _ lMemoryDC, 0, 0, (.Right - .Left), _ (.Bottom - .Top), SRCCOPY tUpdateRect.Left = .Left - lInterval tUpdateRect.Top = .Top - lInterval tUpdateRect.Right = tUpdateRect.Left + _ (.Right - .Left) + (2 * lInterval) tUpdateRect.Bottom = tUpdateRect.Top + _ (.Bottom - .Top) + (2 * lInterval) Else With tUpdateRect lhRng = CreateRectRgn _ (.Left, .Top, .Right, .Bottom) End With RedrawWindow lWBHwnd, 0, lhRng, _ RDW_INVALIDATE + RDW_ALLCHILDREN DoEvents With tUpdateRect StretchBlt _ lDC, .Left + lInterval - (CYCLE / 2), _ .Top + lInterval - (CYCLE / 2), _ (.Right - .Left) - (lInterval - _ (CYCLE / 2)) * 2, (.Bottom - .Top) - _ (lInterval - (CYCLE / 2)) * 2, _ lMemoryDC, 0, 0, (tRect.Right - tRect.Left), _ (tRect.Bottom - tRect.Top), SRCCOPY End With End If End With ReleaseDC 0, lDC lInterval = lInterval + 1 If lInterval = CYCLE Then If bPlayBeep Then Beep lInterval = 0 End If End Sub Private Sub TimerProc2() KillTimer lWBHwnd, 0 Call TakeRangeSnapShot(ByVal oPulsatingRange) End Sub Private Sub GetRngBmpHandle _ (lDC As Long, lRngLeft As Long, lRngTop As Long, _ lRngWidth As Long, lRngHeight As Long) Dim lBmp As Long lMemoryDC = CreateCompatibleDC(lDC) lBmp = CreateCompatibleBitmap(lDC, lRngWidth, lRngHeight) DeleteObject SelectObject(lMemoryDC, lBmp) BitBlt lMemoryDC, 0, 0, lRngWidth, lRngHeight, _ lDC, lRngLeft, lRngTop, SRCCOPY ReleaseDC lMemoryDC, 0 End Sub Private Function ScreenDPI(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(Points As Single, bVert As Boolean) As Long PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH End Function Private Function GetRangeRect(ByVal rng As Range) As RECT Dim tPt1 As POINTAPI Dim tPt2 As POINTAPI Dim OWnd As Window On Error Resume Next Set OWnd = rng.Parent.Parent.Windows(1) With rng GetRangeRect.Left = _ PTtoPX(.Left * OWnd.Zoom / 100, 0) _ + OWnd.PointsToScreenPixelsX(0) GetRangeRect.Top = _ PTtoPX(.Top * OWnd.Zoom / 100, 1) _ + OWnd.PointsToScreenPixelsY(0) GetRangeRect.Right = _ PTtoPX(.Width * OWnd.Zoom / 100, 0) _ + GetRangeRect.Left GetRangeRect.Bottom = _ PTtoPX(.Height * OWnd.Zoom / 100, 1) _ + GetRangeRect.Top End With With GetRangeRect tPt1.x = .Left tPt1.y = .Top tPt2.x = .Right tPt2.y = .Bottom ScreenToClient lWBHwnd, tPt1 ScreenToClient lWBHwnd, tPt2 .Left = tPt1.x .Top = tPt1.y .Right = tPt2.x .Bottom = tPt2.y End With End Function تحياتي

هذا كود الاستاذ محمد صالح E = CreateObject("Scripting.FileSystemObject").GetDrive("C:\").serialnumber MsgBox E

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

يعني تريد اظهار الاسم ورقم الحساب كامل في عمود D هل هذا هو المطلوب ؟؟؟ جرب المرفق Bo2_ALIDROOS_1.rar

نرجو ارفاق الملف الاساسي ان كان به اسرار عمل ارسلة على ايميلي maicl2010ye@gmail.com وان شاء الله نحل المشكلة تحياتي

استبدل هذا الكود علية اضافة مسح المعادلة للعمود الاضافي Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Not Intersect(Target, Range("E3:E101")) Is Nothing Then Application.EnableEvents = False Application.ScreenUpdating = False E = Cells(Rows.Count, 1).End(xlUp).Row Range("C3", Cells(E, "C")).FormulaR1C1 = "=MID(RC[-2],4,6)" ALI Dim ALI_R As Range Set ALI_R = Range("C3:C101").Find(what:=Target, lookat:=xlWhole) If Not ALI_R Is Nothing Then Target.Offset(0, -1).Value = ALI_R.Offset(0, -1).Value Else Target.Offset(0, -1).Value = Empty End If End If Range(Cells(3, "C"), Cells(E, "C")).ClearContents Application.EnableEvents = True Application.ScreenUpdating = True End Sub Sub ALI() Application.EnableEvents = False Application.ScreenUpdating = False For Each R In Range("C3:C101") If R.Value <> Empty Then R.Value = R.Value End If Next R Application.EnableEvents = True Application.ScreenUpdating = True End Sub

تفضل جرب وابلغنى بالنتائج Bo2_ALIDROOS.rar

كنت اعمل على كود وتوصلت الى حل حط هذه الاكواد في حدث ورقة sheet1 Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("E3:E101")) Is Nothing Then Application.EnableEvents = False Application.ScreenUpdating = False E = Cells(Rows.Count, 1).End(xlUp).Row Range("C3", Cells(E, "C")).FormulaR1C1 = "=MID(RC[-2],4,6)" ALI Dim ALI_R As Range Set ALI_R = Range("C3:C101").Find(what:=Target, lookat:=xlWhole) If Not ALI_R Is Nothing Then Target.Offset(0, -1).Value = ALI_R.Offset(0, -1).Value Else Target.Offset(0, -1).Value = Empty End If End If Application.EnableEvents = True Application.ScreenUpdating = True End Sub Sub ALI() Application.EnableEvents = False Application.ScreenUpdating = False For Each R In Range("C3:C101") If R.Value <> Empty Then R.Value = R.Value End If Next R Application.EnableEvents = True Application.ScreenUpdating = True End Sub

ماهي المشكلة ؟؟

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

السلام عليكم الاخ الفاضل مروان هذا حل بالمعادلات حط هذه المعادلة في عمود C3 واسحب للاسفل هذا يعتبر عمود اضافي =MID(A3;4;6) وهذه المعادلة في عمود D3 واسحب للاسفل =INDEX(B$3:B$500;MATCH(1;($C$3:$C$500=E3)*1;0)) هذه معادلة صفيف لاتنسى تضغط Ctrl+Shift+Enter واكتب الرقم المختصر في عمود E3 وانت رايح ولاكن هذا الحل يفي بالغرض الى ان نتوصل لكود يحل محل المعادلات وهذه المرفقات Bo2_ALI.rar

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

السلام عليكم حط هذه المعادلة في خلية G6 واسحب لاسفل =IF(OR(D6="";E6="");"";D6*E6) تحياتي

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

او هكذا اضمن هذا الكود حطه في حدث الورقة Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column = 1 And Target.Row > 1 Then Call ALIDROOS_JC End Sub وهذا الكود في مودويل Sub ALIDROOS_JC() For Each R In Range("A2:A500") If R.Interior.Color <> RGB(255, 255, 255) Then R.Offset(0, 1).Resize(1, 3).Interior.Color = R.Interior.Color End If Next R End Sub