عبدالله باقشير

السلام عليكم جرب التالي RightHeader = Sheets("Sheet1").Range("A1").Value & Chr(13) & Sheets("Sheet1").Range("A2").Value تحياتي

=IF(ISERROR(VLOOKUP(A2;'القائمة الرئسية'!$A$2:$B$1000;2;0));"اعتماد";IF(VLOOKUP(A2;'القائمة الرئسية'!$A$2:$B$1000;2;0)=B2;"موجود";"تحديث"))

هذا ما قصدته من تغيير الدالة

السلام عليكم ضع المعادلة هذه في الخلية C2 واسحبها على باقي العمود =IF(ISERROR(VLOOKUP(A2;'القائمة الرئسية'!$A$2:$B$565;2;0));"اعتماد";IF(VLOOKUP(A2;'القائمة الرئسية'!$A$2:$B$565;2;0)=B2;"موجود";"تحديث")) تحياتي

او غير الدالة بهذه Function Ls_Nm(rng As Range, Sb As String) As String Dim r As Long Dim v As String With rng For r = .Rows.Count To 1 Step -1 If InStr(CStr(.Item(r)), Sb) Then v = CStr(.Item(r)) Exit For End If Next End With Ls_Nm = v End Function تحياتي

غي الدالة بهذه Function Ls_Nm(rng As Range, Sb As String) As String For Each R In rng If InStr(R.Text, Sb) Then v = CStr(R) Next Ls_Nm = v End Function بحيث تضع النطاق في الدالة =Ls_Nm($C$4:$C$27;"1*")

غير شرط الدالة If R.Text Like Sb Then V = CStr(R) بهذا السطر If InStr(R.Text, Sb) Then v = CStr(R) تحياتي

السلام عليكم صحح الكود بهذا Private Sub CommandButton1_Click() Dim RdNG As Range Set RdNG = Sheets("PA1").Range("A1:A8000") For Each cell In RdNG If cell.Value = ActiveCell Then Sheets("PA1").Activate cell.Select Exit For End If Next End Sub تحياتي

غير نوع المتغيرات من Integer الى Long Dim i As Long, ii As Long, Lr As Long واصبر شويه تنال مرادك تحياتي

جزاكم الله خيرا

و مع تقبل احترامى _ فى حالة عدم الطباعه مع وجود شريط تمرير _ هل ممكن تصدير البيانات المستخرجه لصفحه جديده لأمكان طباعتها بطريقه مبسطه شاهد المرفق 2010 المرضى المزمنين++.rar

غير سطر شرط البحث بهذا If InStr(1, .Cells(i, "B"), Me.TextFind, vbTextCompare) = 1 Then تحياتي

غير سطر شرط البحث بهذا If InStr(1, .Cells(i, "B"), Me.TextFind, vbTextCompare) Then تحياتي

السلام عليكم جزاكم الله خيرا تقبلوا تحياتي وشكري

السلام عليكم حل آخر معادلة الفلس =MOD(K14*J14;1000) معادلة الدينار =(L14*J14)+INT((K14*J14)/1000) تحياتي نموزج 1.rar

تفضل المرفق 2003 Test222222222.rar

السلام عليكم جزاكم الله خير وكل عام وانتم بخير تقبلوا تحياتي وشكري

جزاكم الله خيرا وتقبل الله منا و منكم صالح الاعمال وكل عام وانتم بخير تقبلوا تحياتي وشكري

جزاكم الله خيرا وتقبل الله منا و منكم صالح الاعمال وكل عام وانتم بخير تقبلوا تحياتي وشكري

وعليكم السلام اسعدني مروركم جزاكم الله خيرا تقبلوا تحياتي وشكري

السلام عليكم الشكر واصل للجمع المبارك...جزاكم الله خيرا لاثراء الموضوع ولزيادة الحلول Sub Adr1() kh1_Hidden 2 End Sub Sub Adr2() kh1_Hidden 302 End Sub Sub Adr3() kh1_Hidden 602 End Sub Sub Adr4() kh1_Hidden 902 End Sub Sub kh1_Hidden(Adr) With Sheet1 .Rows(2 & ":" & .Rows.Count).Hidden = True .Rows(Adr).Resize(300).Hidden = False .Activate .Cells(Adr, "A").Select End With End Sub المرفق 2003 الاخفاء-kh.rar

غير مفهوم

السلام عليكم استدراك هنا خطا غير مقصود في الكود في السطر If .Cells(i, "A").Value = Ar(C) Then XX(C + 1, iii) = vv يجب تعديله الى If .Cells(i, "A").Value = Ar(C) Then XX(C + 1, ii) = vv وهذا الكود بعد التعديل Sub kh_Report() Dim obj As Object Dim Ar() As Double, XX() As Double, X() As Double Dim v As Double, vv As Double Dim Rng As Range Dim LastRow As Long, iCont As Long Dim i As Long, ii As Long, iii As Long, R As Long Dim C As Integer Dim tx '''''''''''''''''''''' On Error GoTo kh_ex Set obj = CreateObject("Scripting.Dictionary") ''''''''''''''''''''' '============================================ kh_Clear '============================================ With ورقة2 LastRow = .Cells(Rows.Count, "A").End(xlUp).Row Set Rng = .Range("A1:D" & LastRow) End With '============================================ ReDim Ar(1 To ContColmn - 1) For C = 1 To ContColmn - 1 Ar(C) = Range("B1").Cells(1, C).Value Next tx = Range("F1").Value '============================================ kh_Application False With Rng .Sort .Columns(2), xlAscending For i = 1 To .Rows.Count v = .Cells(i, "B").Value vv = Val(.Cells(i, "D")) If obj.Exists(v) Then iii = obj(v) '''''''''''''''''' If .Cells(i, "C").Value = tx Then For C = 1 To ContColmn - 1 If .Cells(i, "A").Value = Ar(C) Then XX(C + 1, iii) = XX(C + 1, iii) + vv Next End If Else ii = ii + 1 ReDim Preserve XX(1 To ContColmn, 1 To ii) obj.Add v, ii '''''''''''''''''' XX(1, ii) = v If .Cells(i, "C").Value = tx Then For C = 1 To ContColmn - 1 If .Cells(i, "A").Value = Ar(C) Then XX(C + 1, ii) = vv Next End If End If Next End With ''''''''''''''''''''''''''''''' iCont = obj.Count If iCont Then 'Erase Ar ReDim Ar(1 To ContColmn - 1) ReDim X(1 To iCont, 1 To ContColmn) For i = 1 To iCont X(i, 1) = XX(1, i) For C = 1 To ContColmn - 1 Ar(C) = Ar(C) + XX(C + 1, i) X(i, C + 1) = Ar(C) Next Next With Range("A2").Resize(iCont, ContColmn) If iCont > 1 Then .Rows(1).AutoFill .Cells, xlFillFormats .Value = X End With ''''''''''''''''''''''''' End If '============================================ kh_ex: kh_Application True '''''''''''''''''' '''''''''''''''''' '''''''''''''''''' Set obj = Nothing Set Rng = Nothing Erase XX, X, Ar '''''''''''''''''' If Err Then MsgBox "Err.Number : " & Err.Number Err.Clear End If End Sub تحياتي

السلام عليكم يتم استخراج البيانات لكل القيم الفريدة في العمود بي للورقة Data1 Option Explicit Private Const ContColmn As Integer = 5 '====================================================== '====================================================== Sub kh_Report() Dim obj As Object Dim Ar() As Double, XX() As Double, X() As Double Dim v As Double, vv As Double Dim Rng As Range Dim LastRow As Long, iCont As Long Dim i As Long, ii As Long, iii As Long, R As Long Dim C As Integer Dim tx '''''''''''''''''''''' On Error GoTo kh_ex Set obj = CreateObject("Scripting.Dictionary") ''''''''''''''''''''' '============================================ kh_Clear '============================================ With æÑÞÉ2 LastRow = .Cells(Rows.Count, "A").End(xlUp).Row Set Rng = .Range("A1:D" & LastRow) End With '============================================ ReDim Ar(1 To ContColmn - 1) For C = 1 To ContColmn - 1 Ar(C) = Range("B1").Cells(1, C).Value Next tx = Range("F1").Value '============================================ kh_Application False With Rng .Sort .Columns(2), xlAscending For i = 1 To .Rows.Count v = .Cells(i, "B").Value vv = Val(.Cells(i, "D")) If obj.Exists(v) Then iii = obj(v) '''''''''''''''''' If .Cells(i, "C").Value = tx Then For C = 1 To ContColmn - 1 If .Cells(i, "A").Value = Ar(C) Then XX(C + 1, iii) = XX(C + 1, iii) + vv Next End If Else ii = ii + 1 ReDim Preserve XX(1 To ContColmn, 1 To ii) obj.Add v, ii '''''''''''''''''' XX(1, ii) = v If .Cells(i, "C").Value = tx Then For C = 1 To ContColmn - 1 If .Cells(i, "A").Value = Ar(C) Then XX(C + 1, iii) = vv Next End If End If Next End With ''''''''''''''''''''''''''''''' iCont = obj.Count If iCont Then Erase Ar ReDim Ar(1 To ContColmn - 1) ReDim X(1 To iCont, 1 To ContColmn) For i = 1 To iCont X(i, 1) = XX(1, i) For C = 1 To ContColmn - 1 Ar(C) = Ar(C) + XX(C + 1, i) X(i, C + 1) = Ar(C) Next Next With Range("A2").Resize(iCont, ContColmn) If iCont > 1 Then .Rows(1).AutoFill .Cells, xlFillFormats .Value = X End With ''''''''''''''''''''''''' End If '============================================ kh_ex: kh_Application True '''''''''''''''''' '''''''''''''''''' '''''''''''''''''' Set obj = Nothing Set Rng = Nothing Erase XX, X, Ar '''''''''''''''''' If Err Then MsgBox "Err.Number : " & Err.Number Err.Clear End If End Sub شاهد المرفق 2010 Ex1.rar