سليم حاصبيا

تم معالجة الأمر MY_Company.xlsx

اذا كنت قد فهمت السؤال جيدا! المطلوب هذا الملف Company.xlsx

try this file Digit_sum.xlsx

الصديق m_127 يمكن عمل ذلك بالمعادلات لكن هناك مشكلة انه تتغير الأرقام كلما غيرت حلية او عدة خلايا في الشبت (لأن المعادلة تعتمد على Randbetween ) اليك هذا المثال كل ما عليك كتابة الـــ Min و الــ Max المعادلات محمية (دون باسبرورد) لعدم العبث بها عن طريق الخطأ اذا اردت نسخها او التعديل عليها فقط ارفع الحماية عن الشيت Rand_By_Formula.xlsx

هذا ماكرو اخر يدرج لك ارقاماً عشوائية بين 1 و اي رقم تختارة في الخلية D2 اذا كانت الخلية D2 فارغة او أقل من صفر يتم اختيار الارقام بين 1 و 10 Option Explicit Sub Rand() Dim HowMany As Long Dim X As Long, Y As Long Dim Tmp() As Long Dim Arr() As Long HowMany = [D2] If Val(HowMany) <= 0 Then _ HowMany = 10: [D2] = HowMany ReDim Arr(1 To HowMany) ReDim Tmp(1 To HowMany) For X = 1 To HowMany Arr(X) = X Next For X = UBound(Arr) To LBound(Arr) Step -1 Y = Int((X - LBound(Arr) + 1) * Rnd + LBound(Arr)) Tmp(X) = Arr(Y) Arr(Y) = Arr(X) Arr(X) = Tmp(X) Next With Cells(1, "A").CurrentRegion.Columns(1) .ClearContents Cells(1).Resize(UBound(Arr)) = _ Application.Transpose(Arr) End With Erase Arr: Erase Tmp End Sub

استاذ أحمد حفاظاً على حق الملكية الفكرية كان يجب ذكر صاحب الملف (و أنا متاكد ان هذا سقط منك سهواً) و بالمناسبة تعديل بسيط على الكود حتى لا تظهر أحطاء في جال قام المستخدم بكتابة نصوص او ارقام سالبة Option Explicit Sub rand_num() If ActiveSheet.Name <> "ورقة1" Then Exit Sub Dim i% If Val([f2]) <= 0 Then [f2] = 1 If Val([g2]) <= 0 Then [g2] = 10 [f2] = Int([f2]): [g2] = Int([g2]) Dim myStart%: myStart = Application.Min([f2], [g2]) Dim myEnd%: myEnd = Application.Max([f2], [g2]) Dim a() Range("C2", Range("C1").End(4)).ClearContents ReDim a(myEnd - myStart) With CreateObject("System.Collections.SortedList") Randomize For i = myStart To myEnd .Item(Rnd) = i Next i For i = 0 To .Count - 1 a(i) = .GetByIndex(i) Next End With Range("C2").Resize(UBound(a) + 1).Value = Application.Transpose(a) Erase a End Sub

تم التعديل على الكود ليحلب البيانات من أي صف و ليس الخامس فقط Option Explicit Sub My_FindNext() Dim T As Worksheet, Sh As Worksheet Dim Opt_rg As Range, Sing_cel As Range Dim Find_Range, SH_rg As Range Dim My_rg As Range Dim Ro1%, m%, RO%, col% Dim mot Dim x As Boolean Dim Match As Boolean Dim arr(1 To 3) arr(1) = "data": arr(2) = "datac": arr(3) = "takrir": Set T = Sheets("takrir") RO = T.Cells(Rows.Count, 2).End(3).Row If RO < 4 Then RO = 4 T.Range("A4:j" & RO + 1).Clear Set Find_Range = T.Range("a2:J2").Find("*", Lookat:=1) If Find_Range Is Nothing Then MsgBox "not Found" Exit Sub End If m = 4 mot = Find_Range.Value: col = Find_Range.Column - 1 For Each Sh In Sheets Match = IsError(Application.Match(Sh.Name, arr, 0)) If Not Match Then GoTo Next_Sheet Set SH_rg = Sh.Range("A1:I10000").Columns(col) Set Find_Range = SH_rg.Find(mot, Lookat:=1) If Find_Range Is Nothing Then GoTo Next_Sheet Do While Not Find_Range Is Nothing If Not x Then Ro1 = Find_Range.Row x = True End If '============================================== If Opt_rg Is Nothing Then Set Opt_rg = Sh.Cells(Find_Range.Row, 1).Resize(, 9) Else Set Opt_rg = Union(Opt_rg, Sh.Cells(Find_Range.Row, 1).Resize(, 9)) End If Set Find_Range = SH_rg.FindNext(Find_Range) If Find_Range.Row = Ro1 Then Exit Do Loop If Not Opt_rg Is Nothing Then Opt_rg.Copy T.Cells(m, 2).PasteSpecial (12) T.Cells(m, 1) = Sh.Name Set Opt_rg = Nothing: m = T.Cells(Rows.Count, 2).End(3).Row + 2 Application.CutCopyMode = False x = False End If '======================================== Next_Sheet: Next Sh If m = 4 Then MsgBox "No Found Data" Exit Sub End If T.Rows(m - 1).Clear With T.Range("A4:J" & m - 2) .Borders.LineStyle = 1: .InsertIndent 1 .Font.Bold = True: .Font.Size = 14 .Interior.ColorIndex = 19 On Error Resume Next For Each Sing_cel In .Columns(2).SpecialCells(4) Sing_cel.Offset(, -1).Resize(, 10) _ .Interior.ColorIndex = 35 Next Sing_cel End With T.Activate: T.Range("A4").Select End Sub Abou hasan_ta33dil.xlsm

يجب وضع هذا ايضاً مع فقرات الــ Dim توقف الكود بسببها Dim Match As Boolean

من أجل استثناء صفحات مغينة يمكن اضافة على الكود ما يلي حسب الصورة المرفق

لا حاجة للتسلسل الرقمي للبيانات لأن اكسل يدرجها اوتوماتيكياً الكود Option Explicit Sub tRANSfERE_DATA() Dim M As Worksheet, D As Worksheet Dim Arr_D, Arr_H, Lr_D As Long Dim rg As Range Set M = Sheets("main"): Set D = Sheets("data") Set rg = D.Range("B3", Range("B2").End(4)) Lr_D = rg.Rows.Count If Lr_D > 10000 Then Lr_D = 3 Else Lr_D = D.Range("B3").Offset(Lr_D).Row End If Arr_D = Application.Transpose(M.Range("D3:D6")) Arr_H = Application.Transpose(M.Range("H3:H12")) D.Cells(Lr_D, 2) = Lr_D - 2 D.Cells(Lr_D, 3).Resize(, UBound(Arr_D)) = Arr_D D.Cells(Lr_D, "G").Resize(, UBound(Arr_H)) = Arr_H End Sub الملف مرفق Commandos.xlsm

الأخ الصديق عبد الفتاح كود أكثر من رائع جزاك الله خيراً لكن نسيت شيئاً وهو تسلسل الأرقام (في حال تكرار الاسم الرقم يجب ان يزيد 1 عما قبله) تعديل بسيط أرجو تقبله Sub rep_nam_num() Dim c As Range If Range("O2").CurrentRegion.Rows.Count > 1 Then _ Range("O2").CurrentRegion.Offset(1). _ Resize(Range("O2").CurrentRegion.Rows.Count - 1).ClearContents For Each c In Range("B3", Range("B" & Rows.Count).End(3)) If c.Value Like "*[ا-ي]*" Then c.Offset(, 13) = c.Value c.Offset(, 14) = c.Offset(, 1).Value Else c.Offset(, 13) = c.Offset(-1, 13).Value c.Offset(, 14) = _ IIf(Val(c.Offset(-1, 14)) = 0, c.Offset(-1, 14), _ c.Offset(-1, 14) + 1) End If Next End Sub Salim.xls

تصحيح الكود Sub DelAll() x = InputBox("إدخل الرقم السري لمسح البيانات", _ "كلمة سر مسح كافة البيانات") If x = "22" Then Dim ws As Worksheet For Each ws In ThisWorkbook.Worksheets With ws If .Name = "data" Or _ .Name = "datab" Or _ .Name = "datac" Then Else .Range("A5:J50000").ClearContents End If End With Next ws Else MsgBox " غير مسموح لك بمسح البيانات", _ vbCritical, "تنبيه" End If End Sub

جرب هذا الكود الصفحة Repport من هذا الملف Option Explicit Sub get_From_To() If ActiveSheet.Name <> "Repport" Then Exit Sub Dim Sw As Worksheet, R As Worksheet Dim Mmin As Byte, Mmax As Byte, i As Byte, S# Dim x%, m%, col As Byte, y As Byte, t As Byte Dim My_ro%, k% Dim Bol As Boolean Set R = Sheets("Repport") If Val(R.Range("D2")) = 0 Or Val(R.Range("E2")) = 0 Then R.Range("D2") = 1: R.Range("E2") = 12 End If Mmin = Application.Min(R.Range("D2:E2")) Mmax = Application.Max(R.Range("D2:E2")) R.Range("D4").CurrentRegion.ClearContents m = 4 For i = 1 To (Mmax - Mmin + 1) R.Cells(4, m) = Mmin + i - 1 m = m + 1 Next t = R.Cells(Rows.Count, 2).End(3).Row col = R.Cells(4, 1).Resize(, m - 1).Columns.Count For x = 5 To t For y = 4 To col Set Sw = Sheets(R.Cells(4, y) & "") If Not Bol Then My_ro = Sw.Range("B:B"). _ Find(R.Cells(x, 2), Lookat:=1).Row Bol = Not Bol End If For k = 5 To 26 Step 3 S = S + Val(Sw.Cells(My_ro, k)) Next k R.Cells(x, y) = S: S = 0 Next y Bol = Not Bol Next x R.Cells(4, y) = "SUM" For x = 5 To t R.Cells(x, col + 1) = _ Application.Sum(R.Cells(x, 4).Resize(, col)) Next R.Cells(t + 1, col + 1) = _ Application.Sum(R.Cells(4, col + 1).Resize(t)) R.Cells(t + 1, 2).Resize(, col). _ Interior.ColorIndex = xlNone R.Cells(t + 1, col + 1). _ Interior.ColorIndex = 6 End Sub File Included MaKhazin_1.xlsm

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

جرب هذا الملف بالتفصيل Fahad Time Sheet.xlsx

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

تم معالجة الامر الكود Option Explicit Sub Get_ALL() Dim Arr(), m, I, itm Dim Ro%, Col%, My_sum# Dim k% m = 1 Principal.Range("B7:B13").ClearContents If Application.CountA(Principal.Range("B4:B6")) < 3 Then MsgBox "Incomplete Data" & Chr(10) & _ "Ckeck Up For Empty The Cells,B4,B5,And B6" Exit Sub End If If Principal.Range("B4") > Sheets.Count - 1 Then Principal.Range("B4") = 1 End If If Principal.Range("B5") > Sheets.Count - 1 Then Principal.Range("B5") = Sheets.Count - 1 End If If Principal.Range("B5") < Principal.Range("B4") Then Principal.Range("B5") = Principal.Range("B4") End If m = 1 For I = Principal.Range("B4") To Principal.Range("B5") ReDim Preserve Arr(1 To m) Arr(m) = Sheets(Principal.Range("B4") + m).Name m = m + 1 Next '++++++++++++++++++++++++++++++++++ For k = 7 To 13 For Each itm In Arr Ro = Sheets(itm).Range("B4:B21").Find(Principal.Range("B6"), lookat:=1).Row Col = Sheets(itm).Range("C3:Z3").Find(Principal.Range("A" & k), lookat:=1).Column + 2 My_sum = My_sum + Val(Sheets(itm).Cells(Ro, Col)) Next itm Principal.Range("B" & k).Value = My_sum My_sum = 0 Next k End Sub الملف مرفق MaKhazin.xlsm

1-كالعادة أول صف قبل الجدول الصف رقم 3 فارغ تماماً 2-يمكنك ادراج الرقم المطلوب ليس فقط في الخلية D2 بل في اي خلية من C2 الى J2 شرط ادراج رقم واحد فقط ( أعني C2 فقط أو F2 فقط أو G2 فقط الخ...) 3- في حال تكرر الرقم المطلوب في نفس الصفحة لا يتعاضى عنه الماكرو (مثلاً الرفم 500 موجود في Sheet1 مرتين وفي Last مرة واحدة ) جربي اكتبي 500 وانقري على الزر الماكرو Option Explicit Sub My_FindNext() Dim T As Worksheet, Sh As Worksheet Dim Opt_rg As Range, Sing_cel As Range Dim Find_Range, SH_rg As Range Dim My_rg As Range Dim Ro1%, m%, RO%, col% Dim mot Dim x As Boolean Set T = Sheets("takrir") RO = T.Cells(Rows.Count, 2).End(3).Row If RO < 4 Then RO = 4 T.Range("A4:j" & RO + 1).Clear Set Find_Range = T.Range("a2:J2").Find("*", Lookat:=1) If Find_Range Is Nothing Then MsgBox "not Found" Exit Sub End If m = 4 mot = Find_Range.Value: col = Find_Range.Column - 1 For Each Sh In Sheets If Sh.Name = T.Name Then GoTo Next_Sheet Set SH_rg = Sh.Range("A1").CurrentRegion.Columns(col) Set Find_Range = SH_rg.Find(mot, Lookat:=1) Do While Not Find_Range Is Nothing If Not x Then Ro1 = Find_Range.Row x = True End If '============================================== If Opt_rg Is Nothing Then Set Opt_rg = Sh.Cells(Find_Range.Row, 1).Resize(, 9) Else Set Opt_rg = Union(Opt_rg, Sh.Cells(Find_Range.Row, 1).Resize(, 9)) End If Set Find_Range = SH_rg.FindNext(Find_Range) If Find_Range.Row = Ro1 Then Exit Do Loop If Not Opt_rg Is Nothing Then Opt_rg.Copy T.Cells(m, 2).PasteSpecial (12) T.Cells(m, 1) = Sh.Name Set Opt_rg = Nothing: m = T.Cells(Rows.Count, 2).End(3).Row + 2 Application.CutCopyMode = False x = False End If '======================================== Next_Sheet: Next Sh If m = 4 Then MsgBox "No Found Data" Exit Sub End If T.Rows(m - 1).Clear With T.Range("A4:J" & m - 2) .Borders.LineStyle = 1: .InsertIndent 1 .Font.Bold = True: .Font.Size = 14 .Interior.ColorIndex = 19 On Error Resume Next For Each Sing_cel In .Columns(2).SpecialCells(4) Sing_cel.Offset(, -1).Resize(, 10) _ .Interior.ColorIndex = 35 Next Sing_cel End With T.Activate: T.Range("A4").Select End Sub الملف OmHamza.xlsm

انا مش فاهم انت عايزه ايه بالضبط عندما تختارين العدد المطلوب من خلال الــــ Input Box يتم تكرار بيانات كل صفخة حسب العدد الذي أخترته (هكذا انا فهمت من سؤالك) يرجى ادراج ملف لا يتعدى الثلاث صفحات كلها مليانة Data (على الأكثر 10 صفوف / لا يكفي صفين ) الــ Data يجب ان تكون مختلفة ليست كلها (مصطفى و سليم و الح...) و صفحة مستقلة تكتبين فيها يدوياً كل النتائج التي تتوقعين ان تحصلي عليها

لا حاجة لليوزر في هذه الحالة ABD_AZIZ.xlsm

تم معالجة الأمر 1- ليس هناك من ضرورة لتلوين اي حلية لاحتيار التكرار 2-عند تشغيل الكود تظهر لك رسالة تطلب تحديد عدد التكرار (بين 1 و 9) Option Explicit Sub Get_data() Dim Tar As Worksheet, SH As Worksheet Dim Rg As Range, Rg_Sh As Range Dim Full_Rg As Range Dim Sing_Cel As Range Dim max_Col%, max_Ro%, m%, k%, t%, Ro% Dim Bol As Boolean Dim Fin_Rg As Range Set Tar = Sheets("takrir") Ro = Tar.Cells(Rows.Count, 2).End(3).Row If Ro < 2 Then Ro = 2 Tar.Range("A2:J" & Ro).Clear k = Application.InputBox("How Many Times", Type:=2) If k < 1 Or k > 9 Then MsgBox "Your number must be betwenn 1 and 9" Exit Sub End If For Each SH In Sheets If SH.Name <> Tar.Name Then Set Rg_Sh = SH.Range("A1").CurrentRegion If Rg_Sh.Rows.Count = 1 Then GoTo Next_SH Set Rg_Sh = Rg_Sh.Offset(1) _ .Resize(Rg_Sh.Rows.Count - 1) max_Col = Rg_Sh.Columns.Count max_Ro = Rg_Sh.Rows.Count m = Tar.Cells(Rows.Count, 2) _ .End(3).Row + IIf(Not Bol, 1, 2) Bol = True Tar.Cells(m, 1) = SH.Name For t = 1 To k Tar.Cells(m, 2).Resize(max_Ro, max_Col).Value = _ SH.Cells(2, 1).Resize(max_Ro, max_Col).Value m = Tar.Cells(Rows.Count, 2).End(3).Row + 1 Next t End If Set Fin_Rg = Tar.Range("A:A").Find(SH.Name, lookat:=1) If Not Fin_Rg Is Nothing Then With Fin_Rg.Resize(max_Ro * k, 1) .Merge .VerticalAlignment = 2 End With End If Next_SH: Next SH m = Tar.Cells(Rows.Count, 2).End(3).Row If m = 2 Then Exit Sub Set Full_Rg = Tar.Range("A2:J" & m) With Full_Rg .InsertIndent 1 .Borders.LineStyle = 1 .Font.Bold = True: .Font.Size = 16 .Interior.ColorIndex = 35 For Each Sing_Cel In .Columns(2).SpecialCells(4) Sing_Cel.Offset(, -1).Resize(, max_Col + 1) _ .Interior.ColorIndex = 6 Next End With End Sub الملف مرفق data_by_number.xlsm

عليك بتعديل الماكرو ليتناسب مع الملف عندك أنا رفعت لك فقط تموذح عما تريد ولا أعلم ماذا يوجد في ملفك أنت لهذا نقول ونكرر انه مع كل مشاركة او تساؤل من الضروري رفع ملف لعدم تضييع وقت الاساتذة

جرب هذا الملف Merge_UnMerge Similar_cells.xlsm

آسف لم أفهم اي شيء مما شرحته

جرب المعادلة في مكان لا توحد في خلايا مدمجة (علة العلل بالنسبة للمعادلات) Long_Sum.xlsx