سليم حاصبيا

ربما كان المطلوب Salim_99.xlsx

لا حاجة لادراج الاساسي والاضافات اكسل يحسبها وحده الملف مرفق Rawateb.xlsm

تم التعديل على الماكرو ليتناسب مع المطلوب Option Explicit Sub give_data() Dim N As Worksheet: Set N = Sheets("names") Dim S As Worksheet: Set S = Sheets("Salim") Dim lrN%: lrN = N.Cells(Rows.Count, 3).End(3).Row Dim lrS%: lrS = S.Cells(Rows.Count, 3).End(3).Row Dim t%, i%: i = 6 Dim m%: m = 9 S.Cells(m, 3).Resize(lrS + 10, 8).Clear Do Until i = lrN + 1 If N.Cells(i, "Y") Like "*" & S.Range("m3") & "*" Then With S.Cells(m, 3) t = t + 1 .Value = N.Cells(i, 1) .Offset(, 1) = N.Cells(i, 3) .Offset(, 2) = N.Cells(i, 2) .Offset(, 3) = N.Cells(i, 5) .Offset(, 4) = N.Cells(i, 10) .Offset(, 5) = N.Cells(i, 8) m = m + 1 End With End If i = i + 1 Loop Cells(1, 4) = t If t = 0 Then MsgBox "No Studiant for this category" Exit Sub End If lrS = S.Cells(Rows.Count, 3).End(3).Row With Range("c9").Resize(lrS - 8, 7) .Font.Size = 22 .Borders.LineStyle = 1 .Interior.ColorIndex = 35 .InsertIndent 1 End With Range("RG_TO_COPY").Copy Cells(lrS + 2, 5) With Cells(lrS + 3, "g") .Formula = "=COUNTIF(F9:F" & lrS & "," & """فرنسي""" & ")" .Offset(1).Formula = "=COUNTIF(G9:G" & lrS & "," & """مسلم""" & ")" .Offset(2).Formula = "=COUNTIF(H9:H" & lrS & "," & """نظامي""" & ")" .Offset(, 2).Formula = "=COUNTIF(F9:F" & lrS & "," & """الماني""" & ")" .Offset(1, 2).Formula = "=COUNTIF(G9:G" & lrS & "," & """مسيحي""" & ")" .Offset(2, 2).Formula = "=COUNTIF(H9:H" & lrS & "," & """منازل""" & ")" End With End Sub الملف من جديد Legan _salim _new.xlsm

جرب هذا الملف Order_Me.xlsm

يمكن اذا اردت ان يكون العمل بواسطة الماكرو VBA Option Explicit Sub give_data() Dim N As Worksheet: Set N = Sheets("names") Dim S As Worksheet: Set S = Sheets("Salim") Dim lrN%: lrN = N.Cells(Rows.Count, 3).End(3).Row Dim t%, i%: i = 6 Dim m%: m = 9 S.Cells(m, 3).Resize(15, 7).ClearContents Do Until i = lrN + 1 If N.Cells(i, "Y") Like "*" & S.Range("m3") & "*" Then With S.Cells(m, 3) t = t + 1 .Value = N.Cells(i, 1) .Offset(, 1) = N.Cells(i, 3) .Offset(, 2) = N.Cells(i, 2) .Offset(, 3) = N.Cells(i, 5) .Offset(, 4) = N.Cells(i, 10) .Offset(, 5) = N.Cells(i, 8) m = m + 1 End With End If i = i + 1 Loop Cells(1, 4) = t End Sub الملف مرفق Legan _salim.xlsm

بعد تنفيذ الماكرو الذي ينظف لك كل شيء اسمه Shapes (مرة واحدة فقط) تستطيع انشاء بوتن جديد

بالنسبة للسؤال الثاني (حل لإزالة التنسيقات) هذا الكود Option Explicit Sub del_shapes() Dim x As Shape For Each x In ActiveSheet.Shapes x.Delete Next End Sub

اذا زاد عدد الصفحات تقوم بالتعديل في هذا القسم من الكود مع مراعاة ان تأخذ الــ K عدداً جديداً من 3 الى 3 + عدد الصفحات -1 في مثلنا عدد الصفحات (بدون الــ Total ) يساوي 3 ====> عدد الصفحات -1=2 ====> 3 + عدد الصفحات -1=5 ====> (اخذنا الــ K من 3 الى 5) Select Case x Case "Excursion": col = 8 Case "Shopping": col = 4 Case "Bonus": col = 3 End Select

جرب هذا الماكرو تم التعديل على الملف قليلاً لتصغير حجمه Option Explicit Sub Get_data() If ActiveSheet.Name <> "Total" Then Exit Sub Dim last_row% Dim k%, r Dim mY_sh As Worksheet last_row = Sheets("Total").Cells(Rows.Count, 2).End(3).Row Sheets("Total").Range("c3", Range("c4").End(4)).Resize(, 3).ClearContents Dim i%: i = 3 Dim x$ Dim col% Do Until Sheets("Total").Range("b" & i) = vbNullString For k = 3 To 5 x = Sheets("Total").Cells(2, k) Set mY_sh = Sheets(x) r = mY_sh.Range("b:b").Find(Sheets("Total").Range("b" & i)).Row Select Case x Case "Excursion": col = 8 Case "Shopping": col = 4 Case "Bonus": col = 3 End Select Sheets("Total").Cells(i, k) = mY_sh.Cells(r, col) Next i = i + 1 Loop Sheets("Total").Range("c3", Range("c4") _ .End(4)).Resize(, 4).NumberFormat = "0.00" End Sub الملف مرفق Total Salim.xlsm

شاهد هذا الفيديو فيه شرح لكل شيء https://www.youtube.com/watch?v=W_GBoDkb2pI

من فضلك حمل الملف في المرة الثانية بدون ألوان فاقعة تبهر النظر ليستطيع من سيحاول المساعدة على فهم الموضوع يمكنك تجربة هذا الملف (بعد تعديل بسيط في تنسيقاته) Legan _salim.xls

استبدل الماكرو بهذا Option Explicit Sub Transfer_data() Dim i%, m%: m = 4 Dim lrA%, My_text Dim Wrd(), t%: t = 1 Dim k% Range("D4").Resize(500, 13).ClearContents lrA = Cells(Rows.Count, "A").End(3).Row For i = 4 To lrA If Range("A" & i) = vbNullString _ Or Range("B" & i) = vbNullString Then GoTo NEXT_I End If My_text = Split(Range("b" & i), " ") For k = LBound(My_text) To UBound(My_text) If My_text(k) <> vbNullString Then ReDim Preserve Wrd(1 To t) Wrd(t) = Application.Substitute(My_text(k), ",", ".") Wrd(t) = IIf(IsNumeric(Wrd(t)), Wrd(t), 0) t = t + 1 End If Next Range("D" & m) = Range("A" & i) Range("E" & m).Resize(1, UBound(Wrd) - LBound(Wrd) + 1) = Wrd m = m + 1 Erase Wrd t = 1 NEXT_I: Next Range("D35") = "TOTAL" Range("E35").Resize(, 12).Formula = _ "=SUM(E4:E34)" End Sub

حاول رفع الملف مرة اخرى لانه في الظاهر لا يمكن تحميله

تم معالجة الامر على هذا العنوان مشاركة رقم 4 http://excel-egy.com/forum/t3550 الملف من جديد TTT_salim_New _Extra.xlsm

‍جرب هذا الملف Ages.xlsx

تم معالجة الامر زخر .xlsx

هذا الكود لهذه الغاية sheet1.range("a1:y10000").Clear

اقترح هذا الماكرو Option Explicit Sub CALCUL() Dim MY_DIC As Object Dim K, m#, x%: x = 3 Set MY_DIC = CreateObject("Scripting.Dictionary") With MY_DIC Do Until Range("B" & x) = vbNullString K = Range("B" & x): m = Range("D" & x) If Not .exists(K) Then .Add K, m Else MY_DIC(K) = MY_DIC(K) + m End If x = x + 1 Loop Range("F3").Resize(.Count) = _ Application.Transpose(.Keys) Range("G3").Resize(.Count) = _ Application.Transpose(.Items) .RemoveAll: Set MY_DIC = Nothing End With End Sub الملف مرفق Working_with_dictionary.xlsm

بعد اذن اخي علي النتيجة في المعادلة تظهر نصاً ويمكن تحويلها لارقام (طبعاً بضربها بــــ 1) فقط اذا كانت A1 و B1 ارقاماً , وإلا تحصل على خطأ في الملف المرفق معادلة تتجاوز هذا الشيء =IF(OR(N(A1)=0,N(B1)=0),"",B1+(A1/(10^(LEN(A1))))) الملف مرفق كمثال Dic_NUMBER.xlsx

الخيار الذي وضعته مستعملاً الدالة Ran في كل مرة تغير اي شيء في اي خلية (او مجموعة خلايا) تتبدل الارقام في عامود الارقام العشوائية مما يرهق البرنامج

لم تستعمل الماكرو كما يجب في هذا الملف قم يتغيير ما تريد ثم اضغط على الزر Run TTT_salim_New.xlsm

بعد اذن الاخ علي كود من سطر واحد Private Sub ترحيل_Click() Sheets("Sheet1").Range("b7").CurrentRegion.SpecialCells(12).Copy _ Sheets("Sheet2").Range("b7").Offset(Sheets("Sheet2") _ .Range("b7").CurrentRegion.Rows.Count) MsgBox "تم الترحيل" End Sub

جرب هذا الكود Option Explicit Sub Transfer_data() Dim i%, m%: m = 4 Dim lrA%, My_text Dim Wrd(), t%: t = 1 Dim k%, lRD% Range("D4").Resize(500, 13).ClearContents lrA = Cells(Rows.Count, "A").End(3).Row For i = 4 To lrA Step 2 My_text = Trim(Range("b" & i)) My_text = Split(My_text, " ") For k = LBound(My_text) To UBound(My_text) If My_text(k) <> vbNullString Then ReDim Preserve Wrd(1 To t) Wrd(t) = My_text(k) t = t + 1 End If Next Range("D" & m) = Range("A" & i) Range("E" & m).Resize(1, UBound(Wrd) - LBound(Wrd) + 1) = Wrd m = m + 1 Erase Wrd t = 1 Next lRD = Cells(Rows.Count, "d").End(3).Row Range("D" & lRD + 1) = "TOTAL" Range("E" & lRD + 1).Resize(, 12).Formula = _ "=SUM(E4:E" & lRD & ")" End Sub الصفحة Salim من هذا الملف TTT_salim.xlsm

استبدل الفاصلة "," بقاصلة منقوطة ";" لتبدو المعادلة هكذا =IF(AND(D5="";E5="");"";IF(D5=E5;,"متزن";"غير متزن")) في حالة كتابة إحدى الخليتين تعطي النتيجة غير متزن كما بالصورة هو هذا المطلوب فكيف يكون اتزان اذا كانت واحدة من الخلايا فارغة والثانبة لا

جرب هذه المعادلة =IF(AND(D5="",E5=""),"",IF(D5=E5,"متزن","غير متزن"))