سليم حاصبيا

Try this file Show_hid.xlsm

1- تم اضافة صفحة جدبدة باسم SALIM تأخذ بياناتها عشوائياً من الشيت G وذلك كي تبقي الشيت الاساسي على بياناتها دون تغيير 2- لا حاجة لادراح اكثر من 20---30 اسم لأان الماكروالذي يعمل على صف واحد يمكنه العملعلى الالوف 3-البيانات في الصفحة G عشوائية لمعرفة مدى فعالية الماكرو (يمكنك استبدالها من الشيت الاساسي عندك غن طريق النسخ واللصق وزيادتتها الى فدر ما تشاء) 4- جرب هذا الملف في الصفحة SALIM بعد الضغط على الزر Run يظهر عندك ماذا كنت تريد 5 _الكود Option Explicit Sub Salim_Mcro() Dim g As Worksheet Dim S As Worksheet Dim Lg%, Ls%, i%, k%, M%, X, Y Set g = Sheets("g") Set S = Sheets("SALIM") Dim Arr() Lg = g.Cells(Rows.Count, 1).End(3).Row If Lg < 17 Then Exit Sub Ls = S.Cells(Rows.Count, 1).End(3).Row If Ls < 17 Then Ls = 17 S.Range("A17:F" & Ls).ClearContents ReDim Arr(1 To Lg - 16) Dim ST$ Dim oBJ As Object Set oBJ = CreateObject("System.Collections.Sortedlist") For i = 1 To Lg - 16 Arr(i) = Application.Transpose(Sheets("g").Range("A" & i + 16).Resize(, 5)) Arr(i) = Application.Transpose(Arr(i)) ST = Join(Arr(i), "*") Randomize Y = Rnd() oBJ.Add Y, ST Next X = oBJ.Count M = 17 For k = 0 To oBJ.Count - 1 S.Cells(M, 1).Resize(, 5) = Split(oBJ.GetBYINDEX(k), "*") M = M + 1 Next End Sub الملف مرفق HiCham2610.xlsm 1- تم اضافة صفحة جدبدة باسم SALIM تأخذ بياناتها عشوائياً من الشيت G وذلك كي تبقي الشيت الاساسي على بياناتها دون تغيير 2- لا حاجة لادراح اكثر من 20---30 اسم لأان الماكروالذي يعمل على صف واحد يمكنه العملعلى الالوف 3-البيانات في الصفحة G عشوائية لمعرفة مدى فعالية الماكرو (يمكنك استبدالها من الشيت الاساسي عندك غن طريق النسخ واللصق وزيادتتها الى فدر ما تشاء) 4- جرب هذا الملف في الصفحة SALIM بعد الضغط على الزر Run يظهر عندك ماذا كنت تريد 5 _الكود Option Explicit Sub Salim_Mcro() Dim g As Worksheet Dim S As Worksheet Dim Lg%, Ls%, i%, k%, M%, X, Y Set g = Sheets("g") Set S = Sheets("SALIM") Dim Arr() Lg = g.Cells(Rows.Count, 1).End(3).Row If Lg < 17 Then Exit Sub Ls = S.Cells(Rows.Count, 1).End(3).Row If Ls < 17 Then Ls = 17 S.Range("A17:F" & Ls).ClearContents ReDim Arr(1 To Lg - 16) Dim ST$ Dim oBJ As Object Set oBJ = CreateObject("System.Collections.Sortedlist") For i = 1 To Lg - 16 Arr(i) = Application.Transpose(Sheets("g").Range("A" & i + 16).Resize(, 5)) Arr(i) = Application.Transpose(Arr(i)) ST = Join(Arr(i), "*") Randomize Y = Rnd() oBJ.Add Y, ST Next X = oBJ.Count M = 17 For k = 0 To oBJ.Count - 1 S.Cells(M, 1).Resize(, 5) = Split(oBJ.GetBYINDEX(k), "*") M = M + 1 Next End Sub الملف مرفق

ربما كان المطلوب Sub Calcul_For_Me() Dim i%, ALL% Dim Fm1$, Fm2$ Dim st$ ALL = Sheets("Total").Cells(Rows.Count, 1).End(3).Row If ALL < 5 Then Exit Sub With Range("B5:C" & ALL) .ClearContents .Interior.ColorIndex = xlNone End With For i = 5 To ALL st = "ISREF('" & Cells(i, 1) & "'!A1" & ")" If Evaluate(st) Then Fm1 = "=SUM('" & Cells(i, 1) & "'!C6:C21)" Fm2 = "=SUM('" & Cells(i, 1) & "'!D6:D21)" ' Cells(i, 2).Formula = Fm1 ' Cells(i, 3).Formula = Evaluate(Fm2) 'OR for values Only Cells(i, 2) = Evaluate(Fm1) Cells(i, 3) = Evaluate(Fm2) Else Cells(i, 2) = "I cant Find This Sheet: " & _ "" & Cells(i, 1) & "" Cells(i, 2).Interior.ColorIndex = 35 End If Next End Sub الملف مرفق tlayt kamal.xlsm

لا أعرف السبب هل يفعل هذا الشيء في الملف الدي رفعته لك؟؟ اذا كنت لا تريد شيئاً في حال كانت الخلية فارغة ضع هذا الشرط في الكود في المكان المناسب (حسب الصورة)

لا شرط لذلك الفلتر يفعلها وحده

بهذه الطريقة سوف تضيع صف العناوين تم التعديل على الملف الاساسي لتبدأ البيانات من االصف 11 مع الاحتفاظ بالصف العاشر كعنوان Extra_Filter _ziad.xlsm

من قال لك ان بيدأ جدولك من الصف رقم 10 الماكرو مصمم ان يبدأ عملة من الصف رقم2 لذلك هو يقوم بمسح كل شيي ابتداء من الصف رقم 2 ونزولاُ ومن ضمنهم الصف 10

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

الكود يظهر كل البينات اذا كانت الخلية H1 فارغة لا اعرف ما المشكلة عندك

مثال اخر (استعمال الفلتر) وتلوين الأصفار Option Explicit Private Sub CommandButton1_Click() Static t% With CommandButton1 If t Mod 2 = 1 Then show_all .Caption = "اخفاء الأصفار" .BackColor = RGB(0, 176, 0) Else Hide_by_flter .Caption = "اظهار الكل" .BackColor = RGB(255, 0, 0) End If End With t = t + 1 End Sub '++++++++++++++++++++++++++++++++ Sub Hide_by_flter() Dim Rg As Range, ro Dim Hd_rg Set Rg = Range("A1").CurrentRegion ro = Rg.Rows.Count If ro = 1 Then Exit Sub With Rg .Interior.ColorIndex = 35 .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 16 .AutoFilter 2, "=0" .AutoFilter 3, "=0" Set Hd_rg = Range("A2:C" & ro - 1).SpecialCells(12) .AutoFilter Hd_rg.Interior.ColorIndex = 6 Hd_rg.EntireRow.Hidden = True End With Range("A1:c1").Interior.ColorIndex = 40 End Sub '+++++++++++++++++ Sub show_all() Range("A1").CurrentRegion.EntireRow.Hidden = False End Sub abo_has_hide_by_filter.xlsm

اين افضل اجابة؟؟

1- ليس من الضروري ان يقوم الماكرو بحلقة تكرارية على 250 صف لأنه يمكن ان يكون اكثرها فارغة يكفي ان يتوقف عند أول خلية فارغة في العامود الأول 2-هذا الماكرو يقوم بتجميع الصفوف التي تحتوي على صفرين في الذاكرة تم يخفيها دفعة واحدة اسرع يكثير للبيانات الكبيرة (اكثر من 1000 صف) 3-كودين على نفس الزر الكبسة الاولى تقوم باخفاء الصفوف و كبسة اخرى باظهارها (مما يسمح بالتعديل على البيانات) Option Explicit Private Sub ToggleButton1_Click() If ToggleButton1 Then hid_rows ToggleButton1.Caption = "اظهار الكل" Else show_all ToggleButton1.Caption = "اخفاء الأصفار" End If End Sub '+++++++++++++++++++++ Sub hid_rows() Dim Hide_range As Range Dim i% i = 2 Range("A1").CurrentRegion.EntireRow.Hidden = False Do Until Cells(i, 1) = vbNullString If Cells(i, 2) = 0 And Cells(i, 3) = 0 Then If Hide_range Is Nothing Then Set Hide_range = Cells(i, 1) Else Set Hide_range = Union(Hide_range, Cells(i, 1)) End If End If i = i + 1 Loop If Not Hide_range Is Nothing Then Hide_range.EntireRow.Hidden = True End If End Sub '+++++++++++++++++ Sub show_all() Range("A1").CurrentRegion.EntireRow.Hidden = False End Sub الملف للمعاينة abo_has_hide.xlsm

تضيف رقمه على الـــ Array الـــ Array يحتوي على الأعمدة الواجب نقلها بالترتيب و تجعل اسم الصفحة في العامود السادس من خلال استبدال الرقم 5 بالرقم 6 في ws.Cells(m, 5) = .Name

تم التعديل على الملف كما تريد Option Explicit Sub Test_Mots_sorted() Dim Sh As Worksheet Dim Ro%, i%, X% Dim KK As Object Set Sh = Sheets("Sheet1") Ro = Sh.Cells(Rows.Count, "E").End(3).Row Sh.Range("F8:Y" & Ro).ClearContents Set KK = CreateObject("System.Collections.Arraylist") For X = 8 To Ro For i = 26 To 65 If Sh.Cells(X, i) Like "#?#" Then If Not KK.Contains(Sh.Cells(X, i).Value) Then KK.Add Sh.Cells(X, i).Value End If End If Next i If KK.Count Then KK.Sort Sh.Cells(X, "F").Resize(, KK.Count) = KK.toarray KK.Clear End If Next X End Sub Abou_sara_sorted_Uniq.xlsm

و هذا الماكرو يوم بترتيب العناصر ابجدياً Option Explicit Sub Test_Mots_sorted() Dim Sh As Worksheet Dim Ro%, i%, X% Dim KK As Object Set Sh = Sheets("Sheet1") Ro = Sh.Cells(Rows.Count, "E").End(3).Row Sh.Range("F8:Y" & Ro).ClearContents Set KK = CreateObject("System.Collections.Arraylist") For X = 8 To Ro For i = 26 To 65 If Sh.Cells(X, i) Like "#?#" Then KK.Add Sh.Cells(X, i).Value End If Next i If KK.Count Then KK.Sort Sh.Cells(X, "F").Resize(, KK.Count) = KK.toarray KK.Clear End If Next X End Sub الملف من جديد Abou_sara_sorted.xlsm

ربما ينفع هذا الماكرو Option Explicit Sub Test_Mots() Dim Sh As Worksheet Dim Ro%, i%, X%, m% Dim arr() Set Sh = Sheets("Sheet1") Ro = Sh.Cells(Rows.Count, "E").End(3).Row Sh.Range("F8:Y" & Ro).ClearContents For X = 8 To Ro For i = 26 To 65 If Sh.Cells(X, i) Like "#?#" Then ReDim Preserve arr(m) arr(m) = Sh.Cells(X, i) m = m + 1 End If Next i If m > 0 Then Sh.Cells(X, "F").Resize(, m) = arr End If Erase arr: m = 0 Next X End Sub الملف مرفق Abou_sara.xlsm

Sub filter_and_copy() Dim my_sheet As Worksheet Dim ws As Worksheet Dim my_rg As Range Dim lra%, k%, m%, v%, X% Dim arr(), S_rg As Range Application.ScreenUpdating = False m = 2 arr = Array(1, 2, 4, 5) k = Sheets.Count Set ws = Sheets("المطلوب") lra = ws.Cells(Rows.Count, 1).End(3).Row If lra < 2 Then lra = 2 ws.Range("A2:E" & lra).Clear my_creteria = ws.Range("H1") For i = 1 To k If Sheets(i).Name = ws.Name Then GoTo Next_i With Sheets(i) Set S_rg = .Range("D:D").Find(my_creteria, lookat:=1) If S_rg Is Nothing Then GoTo Next_i If .AutoFilterMode Then .Range("A1:E1").AutoFilter End If Set my_rg = .Range("A2").CurrentRegion X = .Cells(Rows.Count, 1).End(3).Row '===================================== my_rg.AutoFilter Field:=4, _ Criteria1:="=" & my_creteria & "" For v = LBound(arr) To UBound(arr) .Range("A2:E" & X).Columns(arr(v)).SpecialCells(2).Copy ws.Cells(m, v + 1).PasteSpecial (12) Next Application.CutCopyMode = False ws.Cells(m, 5) = .Name m = ws.Cells(Rows.Count, 2).End(3).Row + 2 If .AutoFilterMode Then .Range("A1:E1").AutoFilter End If '==================================== End With Next_i: Next i v = ws.Cells(Rows.Count, 1).End(3).Row If v < 2 Then GoTo End_Me With ws.Range("A1:E" & v).SpecialCells(2) .Borders.LineStyle = 1 .Font.Bold = True: .Font.Size = 14 .Interior.ColorIndex = 35 .InsertIndent 1 With .Cells(1, 1).Resize(, 4) .Interior.ColorIndex = 6 .HorizontalAlignment = 3 End With End With End_Me: Application.ScreenUpdating = True End Sub تم التعديل على الملف كما تريد 1-المهام مدرجة في قائمة منسدلة في الخلية H1 غير مكررة (توفيراً للوقت في الكتابة من جهة وتجنياً للأخطاء الكتابية من جهة أخرى المسافات الزائدة او النافصة او اخطاء املائية) 2- اذا لم تظهر القائمة المنسدلة غادر الصفحة وعد اليها مجدداً 3- في حال كانت الخلية H1 فارغة الماكرو يقوم بجلب كل البيانات 4-الملف مرفق Extra_Filter.xlsm

بعد وضع المعادلة يجب الضغط على (Crtl+Shift+Enter) لا Enter وحدها

وضعت لك ملفاً مختصراً عما تريد ( 10 أعمدة فقط كنموذج ) المعادلة في العامود J يمكن نسحها والتعديل عليها لوضعها اينما تريد Salim_File.xlsx

تم معالجة الأمر MY_Filter.xlsm

المعادلة غير صحيحة لانك اخترت عامودين مختلفين X و W يجب ان يكون في المعادلة او الجميع X او الجميع W

جرب هذا الملف 1-تختار التاريخ الدي تريد من الخلية A1 ثم نضغط على الزر Get_data يتم اخفاء الأعمدة التي ليس لها علاقة بالتاريخ الدي اخترته 2- المجموع تظهر في الخلية A3 3- اذا كان هناك خطأ ما تطهر لك رسالة بذلك 4- الزر Show_all يظهر لك كافة البيانات Safti.xlsm

ليس امامك اذن الا كود Vba لتنفيذ المطلوب و تخفيف الملف

انت لم تقل اان المطلوب هو 36 دفعة لان بالتأكيد سيصبح الملف ثقيل لهذا يمكن معالجة الأمر امّا بالكود او تغيير تصميم الجدول كما في هذه الصورة (يوجد ملف نرفق) My_EXAMPLE.xlsx

كان يجب رفع ملف بهذا الموضوع ولا تدع الاساتذة يقومون بوضع ملف يحتوي على ما تريد جرب هذا الملف Safti.xlsx