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

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

شاهد الرابط التالي جعلت فيه طلبك هذا http://www.officena.net/ib/index.php?showtopic=42584

غرض البحث للخلايا Range Find Function Find(What, [After], [LookIn], [LookAt], [SearchOrder], [SearchDirection As XlSearchDirection = xlNext], [MatchCase], [MatchByte], [SearchFormat]) As Range Member of Excel.Range سريع جدا

السلام عليكم الاخ الفاضل / عباس السماوي --------------حفظه الله اكرمك الله في الدارين عمل ذكي تقبل تحياتي وشكري

السلام عليكم مثال عملي لتغيير حجم المصفوفة ( ذات البعدين ) دون فقد بياناتها موضوع المصفوفات http://www.officena....showtopic=42397 كود بحث السطر هذا للاعلان عن المصفوفة Dim MyAry() As String السطر هذا للاعلان عن المصفوفة بعد تغيير البعد الاخير مع حفظ المخزون سابقا ReDim Preserve MyAry(1 To 6, 1 To i) اعادة تعيين عناصر الجدول الى قيمتها البدائية مع تحرير الذاكرة Erase MyAry ومن اجل وضع المصفوفة في الخلايا جعلنا صفوفها اعمدة واعمدتها صفوف استخدمنا الدالة Transpose WorksheetFunction.Transpose(MyAry) كود البحث Option Explicit '============================================= '============================================= Sub Kh_Find() Static MySve As String Dim MyAry() As String Dim MyTextFind As Variant Dim FirstAddress As String Dim sFind As Worksheet Dim sPast As Worksheet Dim Cel As Range Dim i As Long Dim ii As Long On Error GoTo 1 Set sPast = Worksheets("نتائج البحث") With sPast .Activate .Range("A2").Select .Range("A2").Resize(2, .UsedRange.Columns.Count).ClearContents .Range("A4").Resize(.UsedRange.Rows.Count).EntireRow.Delete End With MyTextFind = Application.InputBox("اكتب ما تريد البحث عنه ؟", "بحث", MySve, 100, 100, , , 2) If MyTextFind = "" Or MyTextFind = False Then GoTo 2 Set sFind = Worksheets("البحث في المكتبة") '==================================== Application.ScreenUpdating = False Application.Calculation = xlCalculationManual '==================================== With sFind.Range("C1:C65000") Set Cel = .find(MyTextFind, LookIn:=xlValues) If Not Cel Is Nothing Then FirstAddress = Cel.Address Do ii = Cel.Row If ii = 1 Then GoTo NX i = i + 1 ReDim Preserve MyAry(1 To 6, 1 To i) MyAry(1, i) = ii MyAry(2, i) = sFind.Cells(ii, "A").Value MyAry(3, i) = sFind.Cells(ii, "B").Value MyAry(4, i) = sFind.Cells(ii, "C").Value MyAry(5, i) = sFind.Cells(ii, "E").Value MyAry(6, i) = sFind.Cells(ii, "F").Value NX: Set Cel = .FindNext(Cel) Loop While Not Cel Is Nothing And Cel.Address <> FirstAddress End If End With '==================================== If i Then MySve = MyTextFind With sPast .Range("A2").Resize(2, 6).Copy .Range("A2").Resize(i, 6).PasteSpecial xlPasteFormats Application.CutCopyMode = False .Range("A2").Select .Range("A2").Resize(i, 6).Value = WorksheetFunction.Transpose(MyAry) End With End If '==================================== 1: Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic If Err Then MsgBox "Err.Number : " & Err.Number: Err.Clear Else MsgBox IIf(i, "عدد نتائج البحث : " & i, "لا توجد نتائج للبحث "), 524288 + 1048576, "النتيجة" End If 2: Erase MyAry Set sFind = Nothing Set sPast = Nothing Set Cel = Nothing End Sub تم تغيير المرفق بعد وصول عدد التحميل 7 من حمل سابقا فليحمل المرفق الجديد 2003 2007 كود بحث 1.rar

السلام عليكم البحث في ورقة ووضع النتائج في ورقة اخرى Sub Kh_Find1() Static MySve As String Dim MyTextFind As Variant Dim MyShFind As Worksheet Dim RngPast As Range Dim C As Range Dim Mch As Variant Dim i As Integer On Error GoTo 1 MyTextFind = Application.InputBox("اكتب ما تريد البحث عنه ؟", "بحث", MySve, 100, 100, , , 2) If MyTextFind = "" Or MyTextFind = False Then Exit Sub Set MyShFind = Worksheets("البحث في المكتبة") Set RngPast = Worksheets("نتائج البحث").Range("C2") With RngPast .Worksheet.Activate Range(.Cells, .Cells.End(xlDown)).ClearContents End With With MyShFind.Range("C1:C65000") Set C = .find(MyTextFind, LookIn:=xlValues) If Not C Is Nothing Then firstAddress = C.Address Do i = i + 1 Mch = Mch & IIf(i = 1, "", "^^") & C.Value2 Set C = .FindNext(C) Loop While Not C Is Nothing And C.Address <> firstAddress End If End With '==================================== If i Then MySve = MyTextFind If i > 1 Then Mch = WorksheetFunction.Transpose(Split(Mch, "^^")) RngPast.Resize(i, 1).Value = Mch MsgBox "عدد نتائج البحث : " & i Else MsgBox "لا توجد نتائج للبحث " End If '==================================== 1: If Err Then MsgBox "Err.Number : " & Err.Number: Err.Clear Set MyShFind = Nothing Set RngPast = Nothing Set C = Nothing Mch = Empty End Sub المرفق 2003 كود بحث.rar

السلام عليكم اخي الفاضل / الشهابي -------------حفظه الله اخي الفاضل / محمود -------------حفظه الله جزاكما الله خيرا وبارك فيكما اخي الفاضل / ابو انس-------------حفظه الله غير المتغيرات من Integer الى Long حيعمل معاك لكن حتقل سرعة التنفيذ قليلا جرب تقبلوا تحياتي وشكري

السلام عليكم Sub ماكرو1() Dim i As Integer Dim h As Integer For i = 1 To 8 Select Case i Case 1 To 4: h = 1 Case Else: h = 2 End Select MsgBox h Next End Sub

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

السلام عليكم بالنسبة للكود ينقصه فتح الفلترة الموجودة التي تمنع الترحيل للاوراق المرحل لها If Sheets(MySheets).FilterMode Then Sheets(MySheets).ShowAllData جرب التالي بعد التعديل Sub Khboor_Tarheel() Dim SH As Worksheet For Each SH In ThisWorkbook.Worksheets SH.Unprotect Next SH On Error Resume Next Application.ScreenUpdating = False For A = 6 To [C5000].End(xlUp).Row If Cells(A, 3) <> "" Then MySheets = Cells(A, 3) If Sheets(MySheets).FilterMode Then Sheets(MySheets).ShowAllData Sheets(MySheets).[A6:H5000].ClearContents End If Next A For A = 6 To [C5000].End(xlUp).Row If Cells(A, 3) <> "" Then MySheets = Cells(A, 3) With Sheets(MySheets).Cells(A + 2, 1).End(xlUp) .Offset(1, 0) = Cells(A, 1) .Offset(1, 1) = Cells(A, 2) .Offset(1, 2) = Cells(A, 3) .Offset(1, 3) = Cells(A, 4) .Offset(1, 4) = Cells(A, 5) .Offset(1, 5) = Cells(A, 6) .Offset(1, 6) = Cells(A, 7) .Offset(1, 7) = Cells(A, 8) End With End If Next A For A = 6 To [C5000].End(xlUp).Row If Cells(A, 3) <> "" Then MySheets = Cells(A, 3) Sheets(MySheets).[A5:A5000].AutoFilter Field:=1, Criteria1:="<>" End If Next A Application.ScreenUpdating = True MsgBox "!E? C?E???? E??C? Exported data was successful", vbInformation + vbMsgBoxRight, "E? C?E????" Range("A3").Select On Error GoTo 0 For Each SH In ThisWorkbook.Worksheets SH.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _ , AllowFormattingCells:=True, AllowSorting:=True, AllowFiltering:=True Next SH End Sub

الكود تلقائي يعمل الى اخر خلية في اول عمود من النطاق المحدد في MyTopColmnRng ' اسم نطاق رؤوس الاعمدة ' او عنوان رؤوس الاعمدة ملحوقة باسم الورقة Private Const MyTopColmnRng As String = "العمليات!$A$3:$G$3" اخر خليه في العمود يؤخذ بهذه الاسطر من الكود With MyRng ContRow = .Worksheet.Cells(Rows.Count, .Column).End(xlUp).Row - .Row End With فقط غير في كود المسح هنا Sub kh_ClearContents() Range("B16").Resize(500, 8).ClearContents End Sub ليشمل نطاق اوسع بشكل تقريبي للبيانات اللي ممكن تستدعى وضعنا 10016 بدلا من 500 Sub kh_ClearContents() Range("B16").Resize(10016, 8).ClearContents End Sub

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

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

اخي الحبيب / عبدالله المجرب حفظك ربي وشهر مبارك لنا ولكم ولجميع المسلمين شهر الغفران والعتق من النار جعلنا الله واياكم من عتقائه تقبل تحياتي وشكري

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

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

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

جزاك الله خيرا وبارك فيك تقبل تحياتي وشكري

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

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

السلام عليكم ورحمة الله وبركاته احبتي في الله الاخ الفاضل / محمدي عبد السميع__________ حفظه الله الاخ الفاضل / mselmy__________ حفظه الله الاخ الفاضل / محمود علي محمود __________ حفظه الله الاخ الفاضل / جمال الفار__________ حفظه الله شرفتموني بحضوركم الغالي اكرمكم الله في الدارين وجزاكم خيرا وبارك فيكم واثابكم بدعائكم واعطاكم بمثله اضعاف مضاعفة وابلغكم رمضان وغفر لكم ودمتم في حفظ الله

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

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

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

اكرمك الله في الدنيا والاخرة ورزقكم الامن والامان وحفظكم من كل مكروه تقبل تحياتي وشكري