سليم حاصبيا

للببيانات الكبيرة جداً (اكثر من 1000 صف )الماكرو يستهلك الكثير من الوقت لذلك انصح لمثل هذه الحالة هذا الماكرو Option Explicit Sub extract_BY_ADV_FILTER() Dim M As Worksheet, S As Worksheet Dim Rg_M As Range, Rg_S As Range Dim i#, RoS#, col% Dim My_data Set M = Sheets("Main"): Set S = Sheets("Salim1") Set Rg_S = S.Range("A4").CurrentRegion Set Rg_M = M.Range("A1").CurrentRegion RoS = Rg_S.Rows.Count If RoS > 1 Then Rg_S.Offset(1).Resize(RoS - 1).Clear col = S.Cells(1, Columns.Count).End(1).Column My_data = _ Application.Transpose(Application.Transpose(S.Cells(1, 1) _ .Resize(, col))) S.Range("MM2") = Sheets("Main").Cells(1, 1) S.Range("MM3").Resize(col) = Application.Transpose(My_data) Rg_M.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=S.Range("MM2").CurrentRegion, _ CopyToRange:=S.Range("A4").Resize(, 9) S.Range("MM2").CurrentRegion.Clear End Sub الصفحة Salim1 من هذا الملف Repoort_sal_by_ad filter.xlsm

بعد اذن الاستاذ حسين تجد البيانات في شيت salim ربما يفيدك هذا الكود(دائما وابدً اسماء الشيتات باللغة الاجنبية لحسن نسخ الكود ولصقه) Option Explicit Sub extract_data() Dim M As Worksheet, S As Worksheet Dim Rg_M As Range, Rg_S As Range Dim i#, Ro_M#, RoS#, col%, f#: f = 4 Dim My_data, Find_rg Set M = Sheets("Main"): Set S = Sheets("Salim") Set Rg_S = S.Range("A3").CurrentRegion RoS = Rg_S.Rows.Count If RoS > 1 Then Rg_S.Offset(1).Resize(RoS - 1).Clear col = S.Cells(1, Columns.Count).End(1).Column My_data = _ Application.Transpose(Application.Transpose(S.Cells(1, 1).Resize(, col))) Set Rg_M = M.Range("A1").CurrentRegion Ro_M = Rg_M.Rows.Count Set Rg_M = Rg_M.Offset(1).Resize(Ro_M - 1) For i = 1 To Rg_M.Rows.Count If Not IsError(Application.Match(Rg_M.Cells(i, 1), My_data, 0)) Then S.Cells(f, 1).Resize(, 9).Value = _ Rg_M.Cells(i, 1).Resize(, 9).Value f = f + 1 End If Next If f > 4 Then With S.Range("A4").Resize(f - 4, 9) .WrapText = True .Borders.LineStyle = 1 .VerticalAlignment = 2 .InsertIndent 1 End With End If End Sub الملف مرفق مع زر لتنفيذ الكود Repoort_sal.xlsm

ارفع نموذجاً (حوالي 20 صف من البيانات ) لمعالجة الامر

بعد اذن اخي علي هذا الملف (عسى ان ينال الإعجاب) list_uniques.xlsx

اي كود في عالم الــVBA لايسمح بالتراجع لكن اذا اردت التعديل على اي شيء (اضافة سجلا ت ، حذف سجلات ، اوتعديل على الاسماء او القيم ...الخ) يمكنك القيام بذلك ثم العودة الى شيت Archive فتتعدّل النتائج تلقائياً

في هذا الملف تتحدث البيانات كلما فتحت صفحة Archive ولا لزوم للضغط على الزر ALL_data_auto.xlsm

مهما تزايد عد الصفحات الماكرو ياخذها كلها وأي زبون زاد او نقص في اي صفحة يتم التعديل على البيان النهائي جرب ان تزيد ععد الصفحات وادراج زبائن جديدة او قديمة (لكن ابتداء من الخلية B3) من كل صفحة مع الاحتفاظ بعنوان للجدول (الصف الأول) ونفذ الماكرو بالمعادلات من سابع المستحيلات فعل ما تريد

ALL_data.xlsm

حتى هذه اللحظة يظهر عندي 70 تحميل للملف كيف لاتستطيع تحميله لا افهم (ربما المشكلة عندك)

اذا كنت تريدها عبر الماكرو اليك الملف aver_by_choise_new.xlsm

لا يمكن ادراج نتيجة اكثر من معادلة في خلية واحدة يمكن ذلك من خلال كود VBa

جرب هذا الملف aver_by_choise.xlsx

كيف يمكن تعبئة جدول مرتيب ابجديا فقط من خلال الكتابة في الصف رقم 2 للمزيد انظر الى هذا الملف WRITE_JUST IN ROW_2.xlsm

اين الأهمية و سؤالك مطروح منذ اكثر من 24 ساعة جرب هذا الماكرو Option Explicit Sub New_macro() If ActiveSheet.Name <> "Salim" Then Exit Sub Dim S As Worksheet Dim RgA As Range, RgC As Range, RgL As Range Dim m%, x%, R%, Ro% Dim Bol1 As Boolean Set S = Sheets("Salim") Set RgA = S.Range("A4", Range("A3").End(4)) Set RgC = S.Range("C4", Range("C3").End(4)) Set RgL = S.Range("L4").CurrentRegion R = RgL.Rows.Count If R > 1 Then RgL.Offset(1).Resize(R - 1).Clear End If RgA.Copy S.Range("L4") x = 4 '=========================== Do Until S.Range("L" & x) = vbNullString Bol1 = IsError(Application.Match(S.Range("L" & x), RgC, 0)) If Not Bol1 Then Ro = Application.Match(S.Range("L" & x), RgC, 0) + 3 S.Range("L" & x).Resize(, 8).Value = _ S.Range("C" & Ro).Resize(, 8).Value End If x = x + 1 Loop m = x: x = 4 Set RgL = S.Range("L4").CurrentRegion.Columns(1) Do Until S.Range("C" & x) = vbNullString Bol1 = IsError(Application.Match(S.Range("C" & x), RgL, 0)) If Bol1 Then With S.Range("L" & m).Resize(, 8) .Value = S.Range("C" & x).Resize(, 8).Value .Interior.Color = RGB(0, 204, 255) End With m = m + 1 End If x = x + 1 Loop With Range("L4").Resize(m - 4, 8) .Value = .Value .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 14 .InsertIndent 1 .VerticalAlignment = 2 End With End Sub New_Tartib.xlsm

في الخلية D12 هذه المعادلة واسحب يساراً اذا ادخلت بالخطأ في العامود الثاني اي قيمة غير عددية تحصل على فراغ =IF(COUNTA($D$6:$D$10)+COUNT($E$6:$E$10)=10,CHOOSE(COLUMNS($A$1:A1),"المجموع",SUM($E$6:$E$10)),"") المف مرفق Example.xls

تم معالجة الامر بالكامل Sub fil_Profname() Application.ScreenUpdating = False Dim p As Worksheet, T As Worksheet, G As Worksheet Dim x%, xx%, m%, how_many%, r%, i%, y%, mun%: num = 1 Dim resl As Range, F_rg As Range Dim Mth As Range, arr(), cel As Range Dim D_arr() Set p = Sheets("P"): Set T = Sheets("T") Set G = Sheets("GHIAB") Set resl = G.Range("a5").CurrentRegion r = resl.Rows.Count If r > 1 Then resl.Offset(1).Resize(r - 1).Clear x = 4: m = 6 Do Until p.Range("a" & x) = vbNullString '====================================== how_many = Application.CountIf(p.Range("D" & x).Resize(, 500), "Ok") If how_many = 0 Then GoTo Next_x Set Mth = G.Range("P12:P23").Find(G.Range("P5")).Offset(, 1) first = Application.Match(Mth, p.Cells(500, "d").Resize(, 250), 0) + 3 y = Application.CountIf(p.Rows(500), Mth) For Each cel In p.Cells(3, first).Resize(, y) If Month(cel) = Mth And UCase(cel.Offset(x - 3)) = "OK" Then ReDim Preserve arr(1 To num) ReDim Preserve D_arr(1 To num) arr(num) = CDate(cel) D_arr(num) = cel.Offset(-1) num = num + 1 End If Next If num > 1 Then G.Cells(m, 1).Resize(num - 1) = Application.Transpose(arr) G.Cells(m, 2).Resize(num - 1) = Application.Transpose(D_arr) For i = 1 To num - 1 G.Cells(m + i - 1, 3) = p.Cells(x, 1) G.Cells(m + i - 1, 4) = p.Cells(x, 2) G.Cells(m + i - 1, 5) = p.Cells(x, 3) Next m = m + num - 1 End If Erase arr: Erase D_arr: num = 1 Next_x: x = x + 1 Loop Set resl = G.Range("a5").CurrentRegion r = resl.Rows.Count If r = 1 Then Exit Sub Set resl = resl.Offset(1).Resize(r - 1) With resl .InsertIndent 1 .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 14 End With MADDA Application.ScreenUpdating = True End Sub '================================ Sub MADDA() Dim T As Worksheet, G As Worksheet Dim x%, xx%, m%, r1% Dim F_rg As Range Set T = Sheets("T") Set G = Sheets("GHIAB") x = 6: m = 6 Do Until G.Range("A" & x) = vbNullString xx = T.Rows(1).Find(G.Range("B" & x)).Column Set F_rg = T.Columns(1).Find(G.Range("C" & x), lookat:=1) If F_rg Is Nothing Then GoTo Next_x r1 = F_rg.Row G.Cells(m, 6).Resize(, 8).Value = _ T.Cells(r1, xx).Resize(, 8).Value m = m + 1 Next_x: x = x + 1 Loop End Sub الملف medSalim_Final.xlsm

تم معالجة الخطوة الأولى Sub fil_Profname() Application.ScreenUpdating = False Dim p As Worksheet, t As Worksheet, G As Worksheet Dim x%, m%, how_many%, r%, i%, y%, mun%: num = 1 Dim resl As Range, F_rg As Range Dim Mth As Range, arr(), cel As Range Set p = Sheets("P"): Set t = Sheets("T") Set G = Sheets("GHIAB") Set resl = G.Range("a5").CurrentRegion r = resl.Rows.Count If r > 1 Then resl.Offset(1).Resize(r - 1).Clear x = 4: m = 6 Do Until p.Range("a" & x) = vbNullString '====================================== how_many = Application.CountIf(p.Range("D" & x).Resize(, 222), "Ok") If how_many = 0 Then GoTo Next_x Set Mth = G.Range("O12:o23").Find(G.Range("O5")).Offset(, 1) For Each cel In p.Range("D" & 3).Resize(, 222) If Month(cel) = Mth And UCase(cel.Offset(x - 3)) = "OK" Then ReDim Preserve arr(1 To num) arr(num) = cel num = num + 1 End If Next If num > 1 Then G.Cells(m, 1).Resize(num - 1) = Application.Transpose(arr) For i = 1 To how_many G.Cells(m + i - 1, 2) = p.Cells(x, 1) G.Cells(m + i - 1, 3) = p.Cells(x, 2) G.Cells(m + i - 1, 4) = p.Cells(x, 3) Next m = m + how_many End If Erase arr: num = 1 Next_x: x = x + 1 Loop Set resl = G.Range("a5").CurrentRegion r = resl.Rows.Count If r = 1 Then Exit Sub Set resl = resl.Offset(1).Resize(r - 1) With resl .InsertIndent 1 .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 14 End With Application.ScreenUpdating = True End Sub medSalim_1.xlsm

سبق وقلت لك ان الجدول لا يتناسب مع المعطيات لقد وضعت لك جدولا يحدد الأساتذة الغائبين مع عدد ايام الغياب لكل منهم في العامود الاول السؤال: كيف تريد ان توزع ايام الغياب (التواريخ) في صف واحد لو اخذنا مثلاً الاستاذ باري عامر عنده 6 غيابات في تواريخ مختلفة كيف تدرج هذه التواريخ في الصف السادس وفي خلية واحدة ( (A6 ملاحظة :لم احذف الصفحات الباقية بل فقط اخفيتها حتى اتعامل مع الصفات المطلوبة مؤقتاً يرجى اعادة تصميم الجدول اذا كنت تريد تواريخ كل الغيابات للغائبين مع العلم انه يمكن ان يكون هتاك اكثر من مرة غياب فب في شهر واحد الشرح اكثر وضوحاً في الملف المرفق الكود Option Explicit Sub fil_name() Dim p As Worksheet, t As Worksheet, G As Worksheet Dim x%, m%, how_many% Dim resl As Range, r% Set p = Sheets("P"): Set t = Sheets("T") Set G = Sheets("GHIAB") Set resl = G.Range("a5").CurrentRegion r = resl.Rows.Count If r > 1 Then resl.Offset(1).Resize(r - 1).ClearContents x = 4: m = 6 Do Until p.Range("a" & x) = vbNullString how_many = Application.CountIf(p.Range("D" & x).Resize(, 222), "Ok") If how_many > 0 Then With G.Cells(m, 1) .Value = how_many .Offset(, 1) = p.Cells(x, 1) .Offset(, 2) = p.Cells(x, 2) .Offset(, 3) = p.Cells(x, 3) m = m + 1 End With End If x = x + 1 Loop End Sub الملف مرفق (تم تغيير اسم صفحة الغائبين الى GHIAB) لسهولة التعامل مع اللغة الاجنبية من حيث نسخ الكود ولصقه medSalim.xlsm

كيف تريد المساعدة والملف(الكود) محمي بكلمة مرور

ربما يكون الحل Result.xlsx

My_formula.xlsx

المعادلة في المرفق الجدول الاصفر Conditional_Duplicate1.xlsm

بعد اذن الاخ مداد تم تغيير اسم الشيت الى اللفة الاجنبية "salim" (كما اعمل دائماً مع الاكواد لحسن عمل الماكرو من حيث النسخ واللصق) هذا الكود البسيط Option Explicit Sub get_Data() Dim S As Worksheet Dim x%: x = 4 Dim dic As Object Dim ky Set S = Worksheets("salim") S.Range("d4").CurrentRegion.ClearContents Set dic = CreateObject("Scripting.Dictionary") Do Until Cells(x, 1) = vbNullString If Not dic.exists(S.Cells(x, 1).Value) Then dic.Add (S.Cells(x, 1).Value), S.Cells(x, 1).Offset(, 1) End If x = x + 1 Loop '======================== With S.Range("d4").Resize(dic.Count) .Offset(, 1) = _ Application.Transpose(dic.items) .Value = _ Application.Transpose(dic.keys) .Offset(dic.Count).Resize(dic.Count) = _ Application.Transpose(dic.keys) For Each ky In dic.keys dic(ky) = dic(ky) + 1 Next .Offset(dic.Count, 1) = _ Application.Transpose(dic.items) End With Set dic = Nothing: Set S = Nothing End Sub الملف مرفق Conditional_Duplicate.xlsm

تم معالجة الامر مع بعض التحسينات على الكود Option Explicit Sub ABSCENT_EXTRA() Application.Calculation = xlCalculationManual Dim K As Worksheet, A As Worksheet Dim Ro_K%, col%, NUM%, Ro_A%, x%, i%, m%, t%: t = 1 Dim ALL$, ALPHA$, Str$: Str = "غ" ALL$ = " ": ALPHA = " " Set K = Sheets("keab"): Set A = Sheets("arhkeab") Ro_K = K.Cells(Rows.Count, 2).End(3).Row If Ro_K < 5 Then Exit Sub Ro_A = A.Cells(Rows.Count, 2).End(3).Row m = IIf(Ro_A < 5, 5, Ro_A + 1) NUM = m For i = 5 To Ro_K If Application.CountIf(K.Cells(i, 6).Resize(1, 31), Str) = 0 Then _ GoTo My_next A.Cells(m, 2).Resize(, 2).Value = _ K.Cells(i, 2).Resize(, 2).Value For col = 36 To 6 Step -1 If K.Cells(i, col) = Str Then ALL = ALL & col - 5 & "-" End If Next col For col = 6 To 36 If K.Cells(i, col) = Str Then ALPHA = ALPHA & K.Cells(3, col) & "-" t = t + 1 End If Next col If t > 1 Then With A.Cells(m, 4) .Value = Mid(ALL, 1, Len(ALL) - 1) .Offset(, 1) = Mid(ALPHA, 1, Len(ALPHA) - 1) .Offset(, 2) = t - 1 .Offset(, 3) = K.Cells(2, "T") .Offset(, 4) = Year(Date) End With m = m + 1 End If My_next: t = 1 ALL = " ": ALPHA = " " x = x + 1 Next i With A.Range("b" & NUM).Resize(x, 7) .ClearFormats .InsertIndent 1 .Borders.LineStyle = 1 End With Application.Calculation = xlCalculationAutomatic End Sub Tarhil_3iyab (3).xlsm

انا لم اقل انك انت من كتب الكود حتى و لو لم اكن انا من وضع الكود (أي شخص اخر) يجب ان تذكر صاحبه