سليم حاصبيا

اي جدول في الاكسل يجب الا يكون فيه خلايا مدمجة تم اضافة سطر فارغ رقم 2 لازالة الدمج Option Explicit Sub TWO_IN_ONE() Dim RD As Range, RK As Range Range("M2").CurrentRegion.Clear Set RD = Range("d3").CurrentRegion.Columns(3) Set RK = Range("K3").CurrentRegion.Columns(3) With Range("M2").Resize(RD.Rows.Count) .Value = RD.Value .Offset(RD.Rows.Count).Resize(RK.Rows.Count) = _ RK.Value End With With Range("M2").CurrentRegion .Sort Range("M2"): .Interior.ColorIndex = 6 .Borders.LineStyle = 1: .Font.Bold = True End With End Sub الملف مرفق COPY_2 iN 1.xlsm

هناك نموذجان للحل الصفحة Salim والصفحة salim 1 من هذا الملف لا أعرف ايهما تريد Difference_new.xlsx

تم معالجة الامر muorattabat.xlsx

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

حدد بالضبط ماذا تريد 1- ما موجود في الجدول الاول وليس في الثاني 2-ما موجود في الجدول الثاني وليس في الاول 3- المشترك ين الجدولين

اثراء للموضوع هذا الملف (بعد ان فهمت عليك ماذا تريد) Count_sharikat.xlsx

حيرت قلبي معاك على رأي ام كلثوم ارفع مثالاً مع النتائج التي تتوقعها (يدوياً ) لمعابجة الامر

ربما ما تحتاجه في الورقة New من هذا الملف SharikA_Salim.xlsx

لك ماتريد (معادلات مطاطة حتى 1000 اسم) SharikA_Salim.xlsx

بعد اذن الاساتذة الكرام هذه المعادلة في الخلية F3 معادلة صفيف (CTRL+SHIFT+ENTER) =MID(E3,1,MIN(IFERROR(FIND(ROW($A$1:$A$100)&" ",E3)+1,""))) هذه المعادلة في الخلية G3 معادلة صفيف (CTRL+SHIFT+ENTER) =MID(E3,MIN(IFERROR(FIND(ROW($A$1:$A$50)&" ",E3)+1,""))+1,LEN(E3)) الملف مرفق صفحة salim salim2.xlsx

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

أعد صياغة الجدول بحيث يكون هناك مكان لكتابة الشعبة و المادة

كان عليك رفع ملف للمعالجة لكن بامكانك تجربة هذا الشيء Abscence.xlsx

تعديل بسيط على الكود وضع سطر اضافي بين علامات الـــ +++++ Option Explicit Dim ARR() Dim D As Worksheet, P As Worksheet, I# Sub Data_VAL() Dim K%: K = 1 Set D = Sheets("data"): Set P = Sheets("pv") For I = 1 To D.Cells(Rows.Count, 1).End(3).Row If D.Range("A" & I).Interior.Color = RGB(220, 230, 241) Then ReDim Preserve ARR(1 To K) ARR(K) = D.Range("A" & I).Value K = K + 1 End If Next With P.Range("H5").Validation .Delete .Add 3, , , Join(ARR, ",") End With End Sub '++++++++++++++++++++++++++++++++++++++++++++ Sub get_data() Dim First_Ro%, Laste_ro% Dim Copy_RG As Range Dim clas Dim m%: m = 11 Dim col: col = 2 Set D = Sheets("data"): Set P = Sheets("pv") P.Range("A11:C500").ClearContents P.Range("I11:K500").ClearContents clas = P.Range("H5").Value First_Ro = D.Range("A:D").Find(clas, after:=D.Cells(1000, 1), LOOKAT:=1).Row + 4 Laste_ro = D.Range("A" & First_Ro).End(4).Row Set Copy_RG = D.Range(Cells(First_Ro, 2), Cells(Laste_ro, 3)) For I = 1 To Copy_RG.Rows.Count '++++++++++++++++++++++++++++++ If I > P.Range("H6") Then Exit Sub '+++++++++++++++++++++++++++++++ If m = 36 Then m = 11: col = 10 With P.Cells(m, col - 1) .Value = I .Offset(, 1) = Copy_RG.Cells(I, 1) .Offset(, 2) = Copy_RG.Cells(I, 2) End With m = m + 1 Next End Sub الملف من جدبد med_SALIM_new.xlsm

جرب هذا الكود Option Explicit Dim ARR() Dim D As Worksheet, P As Worksheet, I# Sub Data_VAL() Dim K%: K = 1 Set D = Sheets("data"): Set P = Sheets("pv") For I = 1 To D.Cells(Rows.Count, 1).End(3).Row If D.Range("A" & I).Interior.Color = RGB(220, 230, 241) Then ReDim Preserve ARR(1 To K) ARR(K) = D.Range("A" & I).Value K = K + 1 End If Next With P.Range("H5").Validation .Delete .Add 3, , , Join(ARR, ",") End With End Sub '++++++++++++++++++++++++++++++++++++++++++++ Sub get_data() Dim First_Ro%, Laste_ro% Dim Copy_RG As Range Dim clas Dim m%: m = 11 Dim col: col = 2 Set D = Sheets("data"): Set P = Sheets("pv") P.Range("A11:C500").ClearContents P.Range("I11:K500").ClearContents clas = P.Range("H5").Value First_Ro = D.Range("A:D").Find(clas, after:=D.Cells(1000, 1), LOOKAT:=1).Row + 4 Laste_ro = D.Range("A" & First_Ro).End(4).Row Set Copy_RG = D.Range(Cells(First_Ro, 2), Cells(Laste_ro, 3)) For I = 1 To Copy_RG.Rows.Count If m = 36 Then m = 11: col = 10 With P.Cells(m, col - 1) .Value = I .Offset(, 1) = Copy_RG.Cells(I, 1) .Offset(, 2) = Copy_RG.Cells(I, 2) End With m = m + 1 Next End Sub الملف مرفق med_SALIM.xlsm

حسب ما فهمت من السؤال المطلوب هذا الملف ratio.xlsx

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

ربما ينفع هذا الكود Option Explicit Sub Lopping() Dim txt As Object For Each txt In Me.Controls("TextBox") If Mode(txt.Value, 4) <> 0 And txt.Value < 9 Then MsgBox "القيمه المدخله خاطئه" End If Next End Sub

جرب هذا الماكرو Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) With Me.UsedRange .Columns.AutoFit .Rows.AutoFit End With End Sub

ما هي دي نفس المعادلات شغالة زي الفل في الملف المرفق book_s.xls

حرب هذا الماكرو Sub RAND_NUM() Dim i%, k%, M%, Y Dim OBJ As Object Range("A5", Range("A4").End(4)).ClearContents Set OBJ = CreateObject("System.Collections.Sortedlist") For i = 1 To [c2] Randomize Y = Rnd() OBJ.Add Y, i Next M = 5 For k = 0 To OBJ.Count - 1 Cells(M, 1) = OBJ.IndexOfValue(k + 1) + 1 M = M + 1 Next End Sub الملف مرفق Rand_numbers.xlsm

صورة للحل

لا افهم ما الغاية من هذا الشيء لأن الصفحة الثّانية بعد نسخ المعادلات تصبح نسخة طبق الاصل عن الصفحة "بيان" على كل حال اليك هذا الكود للنسخ مع المعادلات Option Explicit Sub FILL_DATA_WITH_FORMULAS() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim R#, i#, m#: m = 3 Dim Maj As Worksheet, Sal As Worksheet Set Maj = Sheets("مجاني") Set Sal = Sheets("SALIM") Sal.Range("A2").CurrentRegion.Offset(1).Clear R = Maj.Cells(Rows.Count, "Z").End(3).Row For i = 2 To R If Maj.Cells(i, "Z") <> vbNullString Then Maj.Cells(i, 1).Resize(, 26).Copy Sal.Cells(m, 1).PasteSpecial (11) m = m + 1 End If Next 'Sal.Columns.AutoFit Sal.Range("A3").CurrentRegion.Borders.LineStyle = 1 With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub

هذا ماكرو اخر يعتمد على المصفوفات (يجب ان يكون اسرع بكثير خاصة اذا كانت البيانات كثيرة ) لا وجد لاي معادلة Option Explicit Sub get_val_BY_ARRYS() Dim My_Sh As Worksheet Dim ARR, S#, T#, R#, I#, k As Byte Set My_Sh = Sheets("Sheet1") R = My_Sh.Cells(Rows.Count, 3).End(3).Row My_Sh.Range("E4").Resize(R - 3, 4).ClearContents For I = 4 To R With My_Sh.Range("D" & I) If Not IsNumeric(.Value) Then GoTo next_i Select Case .Value Case Is < 100: ARR = Array(.Value, "", "") Case Is < 200: ARR = Array(100, .Value - 100, "") Case Is > 200: ARR = Array(100, 100, .Value - 200) End Select .Offset(, 1).Resize(, 3).Value = ARR For k = LBound(ARR) To UBound(ARR) If IsNumeric(ARR(k)) Then T = ARR(k) * Range("L4").Offset(, k) Else T = 0 End If: S = S + T Next .Offset(, 4) = S: S = 0 End With next_i: Next End Sub

الملف كاملاً بواسطة الكود ما عليك الا ان تضغط الزر PRESS ME PLEAS CODE Sub get_val() Dim R#, My_Sh As Worksheet Set My_Sh = Sheets("Sheet1") R = My_Sh.Cells(Rows.Count, 3).End(3).Row With My_Sh.Range("E4").Resize(R - 3) .Resize(, 4).ClearContents .Formula = "=IF(D4<100,D4,100)" .Offset(, 1).Formula = _ "=IF(D4<=100,"""",IF(AND(D4>100,D4<200),D4-100,100))" .Offset(, 2).Formula = _ "=IF(AND(SUM(E4:F4)=200,D4>200),D4-SUM(E4:F4),"""")" .Offset(, 3).Formula = _ "=SUMPRODUCT(E4:G4,$L$4:$N$4)" .Resize(, 4).Value = .Resize(, 4).Value End With End Sub FILE INCLUDED Fatura_new_VBA.xlsm