سليم حاصبيا

تم معالجة الأمر (لا يمكن العمل بدون ماكرو) samia_NEW.xlsm

جرب هذا الملف Option Explicit Sub get_data() Dim Inf As Worksheet Dim sh As Worksheet Dim OBJ As Object Dim S_rg As Range Dim first_row%, sec_row%, m% Dim max_ro%, Arr, ky Set OBJ = CreateObject("Scripting.Dictionary") Set Inf = Sheets("Info") max_ro = Inf.Range("B2").CurrentRegion.Rows.Count If max_ro > 2 Then Inf.Range("B2").CurrentRegion. _ Offset(2).Resize(max_ro - 2).Clear End If If Inf.Range("J1") = vbNullString Then Exit Sub For Each sh In Sheets If sh.Name <> Inf.Name Then Set S_rg = sh.Range("C:C").Find(Inf.Range("J1"), lookat:=1) If Not S_rg Is Nothing Then first_row = S_rg.Row: sec_row = first_row Do Arr = sh.Cells(sec_row, 3).Resize(, 6) Arr = Application.Transpose(Arr) Arr = Application.Transpose(Arr) OBJ(OBJ.Count) = Join(Arr, "*") Set S_rg = sh.Range("C:C").FindNext(S_rg) sec_row = S_rg.Row If sec_row = first_row Then Exit Do Loop End If 'find End If 'name Next 'sh m = 3 If OBJ.Count Then For Each ky In OBJ.keys With Inf.Cells(m, 3) .Resize(, 6) = Split(OBJ(ky), "*") .Offset(, -1) = m - 2 m = m + 1 End With Next With Inf.Range("B3").Resize(m - 2, 7) .Value = .Value .Columns(5).Formula = "=SUM(D3,-E3)" .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14 .Font.Bold = True .Interior.ColorIndex = 19 .Value = .Value End With Inf.Cells(m, 2) = "المجموع" Inf.Cells(m, 4).Resize(, 3).Formula = _ "=SUM(D3:D" & m - 1 & ")" Inf.Range("B" & m).Resize(, 7). _ VerticalAlignment = 2 Inf.Cells(m, 2).Resize(, 2). _ HorizontalAlignment = 7 Inf.Range("B" & m).Resize(, 7).Value = _ Inf.Range("B" & m).Resize(, 7).Value Inf.Range("B" & m).Resize(, 7). _ Interior.ColorIndex = 35 Else MsgBox "This Name Not Exists" End If End Sub الملف مرفق Sandook.xlsm

لا يمكن للمعادلات التلاعب بالخلايا والصفوف من حيث التنسيق او الاحفاء او تغيير الخط او اي شيء اخر هذه الاشياء يفعلها الماكرو كما في هذا الملف Option Explicit Sub get_data() Dim Y As Worksheet, A As Worksheet Dim Ry As Range, Ra As Range Dim cret$, ro% Set Y = Sheets("Youmia") Set A = Sheets("Account") Set Ry = Y.Range("A7").CurrentRegion Set Ra = A.Range("A6").CurrentRegion Ra.Clear cret = A.Range("C2") If cret = "" Then cret = "إيهاب أبو سريع" A.Range("C2") = cret Ry.AutoFilter 7, cret On Error GoTo end_me Ry.Columns(1).Resize(, 3).SpecialCells(12).Copy A.Range("B6").PasteSpecial (12) Ry.Columns(28).Resize(, 2).SpecialCells(12).Copy A.Range("E6").PasteSpecial (12) ro = A.Range("A6").CurrentRegion.Rows.Count If ro > 1 Then A.Cells(ro + 6, 1) = "المجموع" A.Cells(ro + 6, 5).Resize(, 2).Formula = _ "=SUM(E6:E" & ro + 5 & ")" A.Cells(6, 7).Resize(ro + 1).Formula = "=SUM(-E6,F6)" A.Cells(6, 1).Resize(ro) = Evaluate("row(1:" & ro & ")") With A.Range("A6").CurrentRegion.SpecialCells(12) .Interior.ColorIndex = 19 .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14 .Font.Bold = True .Value = .Value .Cells(1, 1).Select End With A.Cells(ro + 6, 1).Resize(, 4).HorizontalAlignment = 7 Y.PageSetup.PrintArea = Y.Range("A1:G" & ro + 6).Address End If end_me: Y.AutoFilterMode = False Application.CutCopyMode = False End Sub الملف مرفق samia.xlsm

يجب ان يكون هناك القليل من البيانات في الجدول لمعرفة كيفية عمل المعادلات تم اضافة بيانات عشوائية جرب هذا الملف samia.xlsx

استاذ محسن مرة ثانية و بدون حلقات تكرارية Option Explicit Dim lr Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False lr = Cells(Rows.Count, 1).End(3).Row If lr < 4 Then GoTo exit_Me If Target.Address(0, 0) = "C2" And _ IsDate(Target) And Target.Count = 1 Then Cells(4, 4).Resize(lr - 3).ClearContents With Cells(4, 4).Resize(lr - 3) .Formula = "=A4&TEXT($C$2,""DMMYYYy"")&""PS""" .Value = .Value End With End If exit_Me: Application.EnableEvents = True End Sub amenbkr.xlsm

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

بعد اذن الاخ حسين لا حاجة للحلقات التكرارية التي ترهق البرنامج (في حال البيانات الكثيرة أكثر من 500 صف) في حين يمكن وضع اليد مباشرة على الخلية المطلوبة بواسطة الدالّة Find Option Explicit Sub find_me() Dim ws1 As Worksheet Dim ws2 As Worksheet Dim RG1 As Range Set ws1 = Sheets("ورقة1") Set ws2 = Sheets("ورقة2") ws2.Cells(7, 2).Resize(4).ClearContents Set RG1 = ws1.Range("A1").CurrentRegion.Columns(2). _ Find(ws2.Range("C3"), Lookat:=1) If Not RG1 Is Nothing Then ws1.Cells(RG1.Row, 1).Resize(, 4).Copy ws2.Cells(7, 2).PasteSpecial (12), Transpose:=True End If Application.CutCopyMode = False ws2.Cells(3, 3).Select End Sub كما يمكن عمل ذلك بمعادلة بسيطة =OFFSET(INDEX(ورقة1!$B$2:$B$9,MATCH($C$3,ورقة1!$B$2:$B$9,0)),,ROWS($A$1:A1)-2) الملف مرفق Adnan.xlsm

كما يمكنك استعمال هذا الماكرو البسيط Option Explicit Sub Get_sum_by_formula() With Sheets("totalICU").Range("B7").Resize(31, 20) .ClearContents .Formula = "=SUM('ICU1:ICU3'!B7)" .Value = .Value End With End Sub

استبدل في الكود الرقم 15 بـــ 19 والرقم 16 بـــــ 20 اي زيادة 4 أعمدة

ربما هذا المطلوب Hani_Mh.xlsx

جرب هذا الملف (تم ازالة زركشات الألوان لتصغير ججم الملف) بالاضافة الى تجسين المعادلات بجيث لا تظهر اخطاء الكود Option Explicit Sub Get_sum() Const Start = 7 Const Fin = 37 Dim ar_sh, Ar_sum(15) Dim A1, A2, A3 Dim ro_ws%, i%, k% ar_sh = Array("ICU1", "ICU2", "ICU3") For i = Start To Fin A1 = Sheets(ar_sh(0)).Range("B" & i).Resize(, 16) A1 = Application.Transpose(A1) A1 = Application.Transpose(A1) A2 = Sheets(ar_sh(1)).Range("B" & i).Resize(, 16) A2 = Application.Transpose(A2) A2 = Application.Transpose(A2) A3 = Sheets(ar_sh(2)).Range("B" & i).Resize(, 16) A3 = Application.Transpose(A3) A3 = Application.Transpose(A3) For k = 0 To 15 Ar_sum(k) = Val(A1(k + 1)) + Val(A2(k + 1)) + Val(A3(k + 1)) Next k Sheets("totalICU").Range("B" & i).Resize(, 16) = _ Ar_sum Next i End Sub Malades.xlsm

لا أعلم اذا كان هذا المطلوب abdelrhmank.xlsx

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

كان من المفروض رفع ملف ولا تدع من يريد المساعدة ان يفعل ذلك التكرارات لا ترحل Option Explicit Sub MY_DATA() Dim M As Worksheet, O As Worksheet Dim Rg_M As Range, Rg_O As Range Dim Ro_M%, i%, How_Many%, _ Ro_O%, t%, n% Dim arr() Set M = Sheets("Main"): Set O = Sheets("Out") Ro_M = M.Cells(Rows.Count, 1).End(3).Row If Ro_M = 1 Then Exit Sub Ro_O = O.Cells(Rows.Count, 1).End(3).Row + 1 For i = 2 To Ro_M How_Many = M.Cells(i, 3) ReDim arr(How_Many - 1, 3) n = 0 For t = LBound(arr) To UBound(arr) arr(t, 0) = M.Cells(i, 1) arr(t, 1) = M.Cells(i, 2) + n arr(t, 2) = M.Cells(i, 3) arr(t, 3) = M.Cells(i, 4) n = n + 1 Next t O.Cells(Ro_O, 1). _ Resize(UBound(arr) + 1, 4).Value = arr Ro_O = Ro_O + UBound(arr) + 1 Erase arr: n = 0 Next i O.Range("A1").Resize(Ro_O - 1, 4).RemoveDuplicates _ Columns:=Array(1, 2, 3, 4) End Sub الملف مرفق prog55.xlsm

Range("F" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Select الكود يعمل معك وانت لا تلاجظ ذلك لأنك دائماً تعمل Selection لنفس الخلية التي هي اول خلية فارغة بالعامود F جرب هذا الكود المرفق بالملف Option Explicit Dim ws As Worksheet Dim RG As Range Dim Time_Run As Date Dim my_st$ Dim i% '++++++++++++++++++++++++ Sub Cyclic_macro() Static x x = i Set ws = Sheets("Sheet1") my_st$ = "Salim" Set RG = ws.Range("A" & Cells.Rows.Count).End(xlUp).Offset(1) RG = my_st & i + 1 i = i + 1 Time_Run = Now + TimeValue("00:00:03") Application.OnTime Time_Run, "Cyclic_macro" End Sub '++++++++++++++++++++++++++++ Sub Stop_Me() On Error Resume Next i = 0 Application.OnTime Time_Run, "Cyclic_macro", , False End Sub '+++++++++++++++++++++++++++++ Sub Clear_data() Set ws = Sheets("Sheet1") i = 0 ws.Range("A2", Range("A1").End(4)).ClearContents End Sub Cyclic_macro.xlsm

شاهد هذا الفيديو https://www.youtube.com/watch?v=l3kBuJtNLgU&ab_channel=TeachExcel

لا حاجة لادراج آلاف الأسماء (عيّنه بسيطة تكفي)لأن الماكرو ديناميكي يأخذ كل الطلاب مهما كان عددهم الكود Option Explicit Dim i Dim arr(1 To 6) Dim Ws As Worksheet Dim New_sheet As Worksheet Dim Rg As Range, Spes_Rg As Range, x% '++++++++++++++++++++++++++++++++++++ Sub ADD_Sheet() Set Ws = Sheets("KOUSHOUFAT") arr(1) = "الأوّل": arr(2) = "الثّاني" arr(3) = "الثّالث": arr(4) = "الرّابع" arr(5) = "الخامس": arr(6) = "السّادس" For i = LBound(arr) To UBound(arr) If Not Application.Evaluate("ISREF('" & _ arr(i) & "'!A1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = arr(i) End If Next End Sub '++++++++++++++++++++++++++++++++++++ Sub Get_Studiantes() Application.ScreenUpdating = False ADD_Sheet Set Rg = Ws.Range("A1").CurrentRegion i = 1 For Each New_sheet In Sheets If New_sheet.Name <> Ws.Name Then New_sheet.Range("A1").CurrentRegion.Clear Rg.AutoFilter 3, arr(i) Rg.SpecialCells(12).Copy With New_sheet.Range("A1") .PasteSpecial (8) .PasteSpecial (12) .PasteSpecial (4) End With Set Spes_Rg = New_sheet.Range("A1").CurrentRegion x = Spes_Rg.Rows.Count If x > 1 Then Spes_Rg.Cells(2, 1).Resize(x - 1).Value = _ Evaluate("row(1:" & x - 1 & ")") End If i = i + 1 End If Next With Application .CutCopyMode = False .ScreenUpdating = True End With Ws.Select Ws.AutoFilterMode = False End Sub الملف مرفق jako.xlsm

مكان الادخال يجب ان يكون احد الخلايا (خلية واحدة و بدون صفوف فارغة) من العامود O ادخال الرقم يجب ان يكون دون اشارة الدولار $ (لأن هذا الاشارة تظهر اوتوماتيكياً) المجموع يظهر في الخلية B2 اوتوماتيكياً

ارفع الملف الذي تعمل عليه لاكتشاف المشكلة

تم معالجة الامر اذا صودف ان شحص او اكثر يملكون نفس الرصيد كما في حالة (شاديا حماد و بانة الرحال) يتم ادراج هذه الاشحاص) Ali_24.xlsm

عمود المبلغ يحتوي على اكثر من خلية اي واحدة تريدين على كل حال جربي هذا الملف اذا وجد البرتامج خلية فارغة (قبل احر حلية في اخر صف) يضع البيانات فيها مثلاُ : الخلية j4 فارغة و اخر ضف في J:J هو رقم 15 يقوم البرنامج بوضع الداتا في الخليتين J4 & I4 Om_hamza_User.xlsm

جرب هذا الملف بالنسبة للسحب صفحة Target بالنسبة لأعلى 3 ايداع أو 4 ايداع أو 5 ايداع (تختار ما تريد من الخلية H1 ) الصفحة Max_3 الكود Option Explicit Sub Get_Sahb() Dim S As Worksheet, T As Worksheet Dim Rg As Range, x% Dim Cret$: Cret = "سحب" Set S = Sheets("Source") Set T = Sheets("Target") T.Range("A2").CurrentRegion.Clear Set Rg = S.Range("A2").CurrentRegion S.AutoFilterMode = False Rg.AutoFilter 9, Cret Rg.SpecialCells(12).Copy T.Range("B2").PasteSpecial (8) T.Range("B2").PasteSpecial (12) S.AutoFilterMode = False x = T.Range("A2").CurrentRegion.Rows.Count If x > 1 Then T.Range("A2") = "#" T.Range("A3").Resize(x - 1) = _ Evaluate("row(1:" & x - 1 & ")") End If With T.Range("A2").CurrentRegion If .Rows.Count > 1 Then .Borders.LineStyle = 1 .InsertIndent 1 .Font.Bold = True .Font.Size = 14 .Interior.ColorIndex = 35 With .Rows(1) .HorizontalAlignment = xlCenter .Interior.ColorIndex = 6 End With End If End With End Sub Ali_244.xlsm

كي يعمل الماكرو يجب كتابة رقم في العامود O ابتداء من O5

معادلة واحدة توضع في الخلية F2 و تسجب 6 أعمدة يميناَ ثم نزولاً صفين عند كتابة المعادلة تضغط (Ctrl+Shift+Enter) وليس Enter وحدها جرب هذا الملف =INDEX($A$2:$C$14,MATCH($E2&MID(F$1,1,3),$A$2:$A$14&$B$2:$B$14,0),3) Dawood.xlsx

ممكن ان يكون المطلوب Ali 99.xlsx