محي الدين ابو البشر

If Sheets("ورقة1").Cells(Y, 1) = TextBox1.Text Then Exit For End If Next Y With Sheets("ورقة1") .Cells(Y, 2) = ComboBox1.Text .Cells(Y, 3) = TextBox2.Text .Cells(Y, 4) = TextBox3.Text .Cells(Y, 5) = TextBox4.Text .Cells(Y, 6) = TextBox5.Text .Cells(Y, 7) = TextBox6.Text .Cells(Y, 8) = TextBox7.Text .Cells(Y, 9) = TextBox8.Text End With جرب هذا التعديل على Private Sub CommandButton2_Click()

أخي العزيز البداية تبدأ من المصفوفة A بدل A = Cells(1).CurrentRegion يجب أن تكون A = Cells(1, 1).Resize(Cells(Rows.Count, 4).End(xlUp).Row, 11) ومن ثم يجب استبدال كل A(i,1) بـ A(i,4) وبما أنك الغيت A(i,4) من المصفوفة Array(A(i, 9), A(i, 10), A(i, 11)) فيجب إضافة سطر آخر في النهاية Sheets("الخلاصة").Cells(1, 1).Resize(.Count) = Application.Transpose(.keys) على كل مبين بالكود التالي Sub test() Dim A As Variant: Dim w As Variant Dim i As Long: Dim ii As Long ' A = Cells(1).CurrentRegion A = Cells(1, 1).Resize(Cells(Rows.Count, 4).End(xlUp).Row, 11) With CreateObject("scripting.dictionary") For i = 1 To UBound(A) If Not .exists(A(i, 4)) Then .Add A(i, 4), Array(A(i, 9), A(i, 10), A(i, 11)) Else w = .Item(A(i, 4)) For ii = 0 To UBound(w) w(ii) = w(ii) + A(i, ii + 9) Next .Item(A(i, 4)) = w End If Next ' Sheets("الخلاصة").Cells(1, 1).Resize(.Count) = Application.Transpose(.keys) Sheets("الخلاصة").Cells(1, 2).Resize(.Count, 3) = Application.Index(.items, 0, 0) Sheets("الخلاصة").Select End With End Sub أرجو أن أكون قد أفدتك وجاهز لأي سؤال جمع المكرر (1) (2).xlsm

فقط استبدل Cells(6, 7).Resize(.Count, UBound(A, 2)) = Application.Index(.items, 0, 0) بالسطر Sheets("Sheet2").Cells(1, 1).Resize(.Count, UBound(A, 2)) = Application.Index(.items, 0, 0)

تفضل أخي الكريم Sub test() Dim A As Variant: Dim w As Variant Dim i As Long: Dim ii As Long A = Cells(1).CurrentRegion With CreateObject("scripting.dictionary") For i = 1 To UBound(A) If Not .exists(A(i, 1)) Then .Add A(i, 1), Array(A(i, 1), A(i, 2), A(i, 3), A(i, 4)) Else w = .Item(A(i, 1)) For ii = 1 To UBound(w) w(ii) = w(ii) + A(i, ii + 1) Next .Item(A(i, 1)) = w End If Next Cells(6, 7).Resize(.Count, UBound(A, 2)) = Application.Index(.items, 0, 0) End With End Sub جمع المكرر.xlsm

هي معادلة واحدة من أثنتين الفارق هو "," و ";" حسب اعدادات الكمبيوتر عندكاكواد.xlsx

E4=IFERROR(INDEX(ورقة1!$B$5:$B$32,MATCH(D26,ورقة1!$A$5:$A$32,0)),"") Or E4=IFERROR(INDEX(ورقة1!$B$5:$B$32;MATCH(D26;ورقة1!$A$5:$A$32;0));"") عليكم السلام ُُE4=IFERROR(VLOOKUP(D4,ورقة1!$A$5:$B$35,2,0),"") OR E4=IFERROR(VLOOKUP(D4;ورقة1!$A$5:$B$35;2;0);"") واسحب نزولا

Book1 (2) (1) (3) (1).xlsM دخلت

Book1 (2) (1) (3) (1).xlsM

أخي العزيز إليك خيارين الأول إضافة ورقة باسم D كما في الملف الذي ارسلته Sub test() Dim a, b, a1, b1, c, c1 Dim i As Long Dim j As Long Dim temp With Sheets("B") a = Join(Application.Transpose(.Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))), "#") b = Join(Application.Transpose(.Range(.Cells(2, 2), .Cells(2, 2).End(xlDown))), "#") End With With Sheets("C") a1 = Join(Application.Transpose(.Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))), "#") b1 = Join(Application.Transpose(.Range(.Cells(2, 2), .Cells(2, 2).End(xlDown))), "#") End With With Sheets("D") c = Join(Application.Transpose(.Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))), "#") c1 = Join(Application.Transpose(.Range(.Cells(2, 2), .Cells(2, 2).End(xlDown))), "#") End With a = Split(a & "#" & a1, "#"): b = Split(b & "#" & b1, "#"): c = Split(c & "#" & c1, "#") With CreateObject("scripting.dictionary") For i = 0 To UBound(a) If Not .exists(a(i)) Then .Add a(i), b(i) Next a = Application.Transpose(Array(.keys, .items)) End With Sheets("A").Cells(2, 1).Resize(UBound(a), 2) = a For i = 1 To (UBound(a, 1) - 1) For j = i To UBound(a, 1) If Val(a(j, 1)) < Val(a(i, 1)) Then temp = a(i, 1): a(i, 1) = a(j, 1): a(j, 1) = temp temp = a(i, 2): a(i, 2) = a(j, 2): a(j, 2) = temp End If Next j: Next i Sheets("A").Cells(2, 1).Resize(UBound(a), 2) = a End Sub والخيار الثاني يمكنادمج أي عدد من الأوراق إلى الورقة الحالية( الموجود فيها زر الدمج Sub test1() Dim a, b, c, c1 Dim i As Long Dim j As Long Dim temp For i = 1 To Sheets.Count If Sheets(i).Name <> ActiveSheet.Name Then With Sheets(i) a = Join(Application.Transpose(.Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))), "#") b = Join(Application.Transpose(.Range(.Cells(2, 2), .Cells(2, 2).End(xlDown))), "#") End With c = IIf(c = "", a, c & "#" & a): c1 = IIf(c1 = "", b, c1 & "#" & b) End If Next c = Split(c, "#"): c1 = Split(c1, "#") With CreateObject("scripting.dictionary") For i = 0 To UBound(c) If Not .exists(c(i)) Then .Add c(i), c1(i) Next a = Application.Transpose(Array(.keys, .items)) End With For i = 1 To (UBound(a, 1) - 1) For j = i To UBound(a, 1) If Val(a(j, 1)) < Val(a(i, 1)) Then temp = a(i, 1): a(i, 1) = a(j, 1): a(j, 1) = temp temp = a(i, 2): a(i, 2) = a(j, 2): a(j, 2) = temp End If Next j: Next i ActiveSheet.Cells(2, 1).Resize(UBound(a), 2) = a End Sub بالمناسبة الأسماء في العمود الأول يجب أن تكون متطابقة حتى الفراغات بعد أو قبل الاسم يعتبر اسم جديد والله الموفق

وهذا خيار آخر Book1 (2) (1).xlsM

عليكم السلام أخي الكريم بالنسبة للكود الذي قدمته لك يعمل جيداً عندي !!! لا أدري ماذا يحصل عندك بالسبة للكود يمكن أن يخدمك بعد التعديل ليصبح Sub compair_columns() Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet Dim a As Variant, b As Variant, v As Variant Dim dic As Object, i As Long, cad As String Application.ScreenUpdating = False Application.DisplayAlerts = False Set sh1 = Sheets("B") Set sh2 = Sheets("C") Set sh3 = Sheets("A") Set dic = CreateObject("Scripting.Dictionary") a = sh1.Range("A2:b" & sh1.Range("A" & Rows.Count).End(xlUp).Row).Value2 b = sh2.Range("A2:b" & sh2.Range("A" & Rows.Count).End(xlUp).Row).Value2 ' dic("exist in A and not in B") = "exist in A and not in B" For i = 1 To UBound(a, 1) cad = a(i, 1) & "|" & a(i, 2) dic(LCase(cad)) = cad Next ' dic("exist in B and not in A") = "exist in B and not in A" For i = 1 To UBound(b, 1) cad = b(i, 1) & "|" & b(i, 2) If Not dic.exists(LCase(cad)) Then dic(LCase(cad)) = cad End If Next sh3.Range("A2").Resize(dic.Count).Value = Application.Transpose(dic.items) sh3.Range("A2:A" & dic.Count + 1).TextToColumns Destination:=sh3.Range("A2"), OtherChar:="|", FieldInfo:=Array(Array(2, 1)) Application.ScreenUpdating = True MsgBox "Done" End Sub لكنه بحاجة لإضافة كود للفرز

Book1 (2).xlsM

ربما Sub test() With Sheets("B") a = Join(Application.Transpose(.Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)))) b = Join(Application.Transpose(.Range(.Cells(2, 2), .Cells(2, 2).End(xlDown)))) End With With Sheets("C") a1 = Join(Application.Transpose(.Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)))) b1 = Join(Application.Transpose(.Range(.Cells(2, 2), .Cells(2, 2).End(xlDown)))) End With a = Split(a & " " & a1): b = Split(b & " " & b1) With CreateObject("scripting.dictionary") For i = 0 To UBound(a) If Not .exists(a(i)) Then .Add a(i), b(i) Next a = Application.Transpose(Array(.keys, .items)) End With Sheets("A").Cells(2, 1).Resize(UBound(a), 2) = a With Worksheets("A").Sort Worksheets("A").Sort.SortFields.Clear Worksheets("A").Sort.SortFields.Add2 Key:=Range("A2:A" & UBound(a) + 1), _ SortOn:=xlSortOnValues, Order:=xlAscending .SetRange Range("A2:b" & UBound(a) + 1) .Header = xlGuess .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End Sub

Book1.xlsx

عليكم السلام اسحب نزولا (ملاحظة إما صباحا أو صباح في الجهتين) G6=COUNTIF($B$2:$B$300,H6)

بارك الله

عليكم السلام عسى يكون المطلوب زر طباعة1.xlsm

C6=IF(AND(ISNUMBER('شيت الرابع'!P12),ISNUMBER('شيت الرابع'!Q12)),'شيت الرابع'!P12+'شيت الرابع'!Q12,IF(ISNUMBER('شيت الرابع'!P12),'شيت الرابع'!P12,'شيت الرابع'!Q12))

لم أفهم ما يعني (يقوم بنقل درجه p فقط دون Q أريد أن يتم نقل الخليتين P + Q أى مجموعتين ) ربما: =IF(ISNUMBER(P12),'شيت الرابع'!P12+'شيت الرابع'!Q12,'شيت الرابع'!P12& "+" &'شيت الرابع'!Q12)

عليكم السلام أكمل على نفس النحو 2022شيت مدرستى - الصف الرابع-.xls

بارك الله فيك أخي الكريم شكراً لك

وعليكم السلام تفضل أخي الكريم بحث فى كل الشيتات.xlsm

Split_names in one cell (1).xlsm

تفضل Split_names in one cell (1).xlsm

السلام عليكم تفضل أخي الكريم ربما! Split_names in one cell (1).xlsm