نجوم المشاركات

الأخ الصديق عبد الفتاح كود أكثر من رائع جزاك الله خيراً لكن نسيت شيئاً وهو تسلسل الأرقام (في حال تكرار الاسم الرقم يجب ان يزيد 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

اليكم رابط برنامج عواصم دول قارة اوربا ودول قارة اسيا من الرابط التالى https://top4top.io/downloadf-1625cng161-rar.html فك ضغط البرنامج وافتح فولدر Relese وسطب البرنامج وده رابط كمان على ميديــا فـــايـــر دول وعواصم قارة اوربا - اسيا ارجو ان ينال اعجابكم واوجه كلمة شكر للقائمين على الموقع جميعا والمشرفين للتشجيع

أكتب هذا الفانك Function azhr(Frm As String) Forms(Frm).AllowEdits = True End Function استدعية من النموذج بهذا الكود Call azhr(Me.Name)

استاذ أحمد حفاظاً على حق الملكية الفكرية كان يجب ذكر صاحب الملف (و أنا متاكد ان هذا سقط منك سهواً) و بالمناسبة تعديل بسيط على الكود حتى لا تظهر أحطاء في جال قام المستخدم بكتابة نصوص او ارقام سالبة 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

لقد تم حل ما طلبته كان من المفترض التوضيح من البداية تفضل هذه المعادلة =IFERROR(INDEX($A$2:$A$23;AGGREGATE(15;6;ROW($A$2:$A$23)-ROW($A$1)/(($B$2:$B$23>=$E$1)*($B$2:$B$23<=$G$1));ROW()-ROW($E$3)));"") إدراج الاسماء تلقائي.xlsx

لا حاجة للتسلسل الرقمي للبيانات لأن اكسل يدرجها اوتوماتيكياً الكود 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

تفضل اخي الكريم test.accdb

جرب هذا الكود الصفحة 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

بسم الله الرحمن الرحيم، السلام عليكم ورحمه الله وبركاته، كل عام وجميع زوار وأعضاء ومشرفي وإدارة منتدى أوفيسنا بكل خير وسعادة، عذرا لقلة مشاركاتي في هذا الصرح الكبير؛ نظرا لانشغالي ببعض الأمور، ولكن أعدكم دائما بكل جديد ومفيد. وفي هذه المرة أحب أن أقدم لكم هدية بعنوان احسب فاتورة الكهرباء المصرية من 2020 الى 2025 مع هذا البرنامج. فقد اصدرت وزارة الكهرباء قرارا بتحديد اسعار اكهرباء ي مصر للخمسة سنوات مقلبة من 2020 الى 2025. وكان ذلك يوم الثلاثاء 9 / 6 / 2020 فقمت بتصميم هذا البرنامج في الاكسس وقمت بعرضه هنا وبانتظار آرائكم ومقترحاتكم لتطويره. رابط الملف المستعمل في الشرح سيكون بناء على تفاعلكم مع الموضوع وتعليقاتكم في اليوتيوب. وهذا الفيديو الخاص بالشرح وعرضت في الفيديو تحديا لمن يهتم ببرمجة الويب في تحويل هذا البرنامج لصفحة ويب فمن لها من اصدقائي؟؟؟!!! وفي الأخير أدعوكم جميعا لزيارة مدونتي في ثوبها الجديد. وفقنا الله جميعا لكل ما يحب ويرضى.

السلام عليكم ورحمة الله وبركاته الاخوه الافاضل بصراحه بحث كثيرا ولم اتوصل لشئ .................................................... اريد كود يقوم بانشاء فولدر جديد ثم يقوم بجعل هذا الفولدر شيرنج على الشبكة ............................................................. تقبلو تحياتى

لا شكر على واجب أخي الكريم @abouelhassan

مشكور استاذنا بارك الله فيك

أخي المبدع سليم سلمت أيديك الذهبية

شكرا لدعمكم أستاذ @محمد احمد لطفى باقي مشاركة الموضوع والفيديو

وعليكم السلام ورحمة الله وبركاته أخي الكريم @إبراهيم ابوليله المحترم أما عن الطلب الأول فقد بحثت عنه وتحققت من أدائه أرجو أن تكون به الفائدة الأكواد منقولة من خلال البحث في النت للأمانة. أما عن الطلب الثاني فالإخوة الكرام أهل لذلك وزيادة (بكم البركة).... تقبل تحياتي العطرة. Option Explicit Dim Status As String Sub Main() Dim LastRow As Long, iRow As Long Dim FolderPath As String Dim wsApp As Worksheet Set wsApp = ThisWorkbook.Worksheets("App") With wsApp LastRow = .Cells(Rows.Count, "B").End(xlUp).Row FolderPath = .Range("FolderPath").Value If Dir(FolderPath, vbDirectory) = vbNullString Then MsgBox "Invalid Base Folder Provided.", vbExclamation Exit Sub End If If 6 > LastRow Then MsgBox "No item provided.", vbExclamation Exit Sub End If For iRow = 6 To LastRow If .Cells(iRow, "B").Value <> "" Then CreateFolder .Cells(iRow, "B").Value, FolderPath .Cells(iRow, "C").Value = Status End If Next iRow End With MsgBox "All folder created successfully.", vbInformation Set wsApp = Nothing End Sub Private Sub CreateFolder(ByVal SubFolder As String, ByVal BaseFolder As String) Dim strTemp As String Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Status = "" strTemp = CleanFolderName(SubFolder) If fso.FolderExists(BaseFolder & "\" & strTemp) Then Status = "Folder Exists Already" Else If Len(strTemp) > 0 Then MkDir BaseFolder & "\" & strTemp Status = "Success" End If End If Set fso = Nothing End Sub Public Function CleanFolderName(ByVal FolderName As String) As String Dim i As Long Dim strTemp As String For i = 1 To Len(FolderName) Select Case Mid(FolderName, i, 1) Case "/", "\", ":", "?", "<", ">", "|" strTemp = strTemp & "_" Case Else strTemp = strTemp & Mid(FolderName, i, 1) End Select Next i CleanFolderName = strTemp End Function إبراهيم أبو ليلة.xlsm

الصديق 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

السلام عليكم ورحمة الله وبركاته،،، الله يعطيك العافية أ. شحادة، يوجد عندي بعض الاستفسارات، وأرجو أن يتسع صدرك لي، وهي كما يلي: عند استخدام خاصية التصحيح التلقائي سيعالج كل علامة ترقيم وإلصاقها بما قبلها وترك مسافة ما بعدها، لكن في حالة وجود عدد عشري مثل (5.2) سنجد أنه حولها إلى (5. 2) وهذا خلل. لا يتم معالجة القوسين الهلالين من حيث المسافة قبل وبعد مثل: ( محمد رسول الله ) لا يضعها (محمد رسول الله). عند إجراء استخدام أي من الإضافات يتم التطبيق على كامل الملف، هل يمكن التطبيق فقط على فقرة محددة بالمتن وليس كل الملف بأكمله؟ لا يمكن عمل تراجع عند استخدام خاصية (نقل الحواشي إلى أعلى ووضعها ضمن...). عند التحويل لـ pdf ألاحظ أن حجم الملف كبير جداً، على سبيل المثال ملف عدد صفحاته 14 صفحة وبدون أشكال فقط نص، عند التحويل وجدت أن حجمه 5 ميغا بايت. عند استخدام زر الحواشي السفلية واختيار (المسافة قبل الحواشي) تظهر لي رسالة "يتضمن نص "البحث عن" تعبيراً غير صحيح لـ "نمط التطابق"، حاولت بملف جديد ووضعت حاشية سفلية واحدة فقط بعدها مسافة وبدأت بالتطبيق، لكن ظهرت نفس المشكلة. ما يتعلق بزر (التلوين) وهو موجود للمعاينة قبل تنفيذ (تصحيح)، وجدت أنه عند الضغط على (التلوين) يضع خط أحمر تحت المشكلة، وهذا الخط لا يمكن إزالته إلا بطريقتين إما عمل تراجع، أو تحديده وعمل إزالة الخط السفلي واللون، لماذا لا يكون زر التلوين فقط للمعاينة بدون تنفيذ، أي بدون أن يكون له تطبيق فعلي، أو الضغط على زر (تلوين) للمعاينة، وعند إزالة الإشارة عن (تلوين) تختفي وكل الخطوط والألوان. إضافة إلى ما تم الحديث عنه سابقاً مشكوراً، تطبيق نفس فكرة فهرسة العناوين على الإشارات المرجعية بحيث يتم إدراج عنوان الإشارة ورقم الصفحة. حقيقة (إضافة البيان البحثية) رائعة جداً، وتسهِّل على الباحث الكثير من الجهد والوقت. كل الشكر والتقدير لجهودكم الطيبة إن شاء الله يكون هذا العمل في ميزان حسناتكم

اخي المعادلة تعمل بناء على التاريخ لا اجد اي منطق لحدف المكرر لانه كل اسم لديه عملية معينة في تاريخ مختلف بالتالي ستجلب الاسماء بناء على تواريخ مختلفة

شكرا جزيلا لك وبارك الله بيك وبجهودك المبذوله في هذا المنتدى

والله يا استاذ على لولا تشجيعك وتشجيع الاستاذ محمد طاهر لتوقفت اشكركم جميعا ولكن هل من ملاحظات للتعديل يسعدنى لو سمعت اقتراحات من المشاركين

وعليكم السلام -يمكنك تجربة هذا الملف -على الرغم ان هذا مخالف لقوانين وتعليمات المنتدى -حيث لا يمكن العمل على التخمين وتجنباً لعدم اهدار وقت الأساتذة فكان عليك لزاماً من البداية رفع ملف مدعوم بشرح كافى عن المطلوب مع وضع النتائج المرجوة الملف من أعمال استاذنا الكبير سليم حاصبيا Rand_Bet.xlsm

ممتاز حضرتك ممتاز والله ربنا يحفظك ماشاء الله عليك استاذ سليم ربنا يرضى عنك كل الشكر والتقدير والاحترام من اخيك

تم التعديل على الكود ليحلب البيانات من أي صف و ليس الخامس فقط 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

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

تسلم ايدك استاذى ربنا يرضى عنك الكود ممتاز ربنا يحفظك اللهم امين كل الشكر والتقدير والاحترام من اخيك

تصحيح الكود 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

بالاضافة الى ما تفضل به استاذي الفاضل kanory وله الشكر اليك هذه الطريقة ارجو ان تفيدك باذن الله myCriteria = "[Gym].[startDate] >= #" & Format(Me.sd, "dd\/mm\/yyyy") & "# And [Gym].[startDate]<= #" & Format(Me.ed, "dd\/mm\/yyyy") & "#" myCriteria = myCriteria & " Or " myCriteria = myCriteria & "[Gym].[endDate] >= #" & Format(Me.sd, "dd\/mm\/yyyy") & "# And [Gym].[endDate]<= #" & Format(Me.ed, "dd\/mm\/yyyy") & "#" Me.subGym.Form.Filter = myCriteria Me.subGym.Form.FilterOn = True 1tray.zip تحياتي

بالخدمة استاذ ازهر عبد العزيز

أخي قاسم هل هناك فرق بين الموضوعين .... ارجو التوضيح حتى نتمكن من مساعدتك .... بارك الله فيك

جرب هذه المعادلة =IF(OR(C6="";D6="");"";IF(AND(ISNUMBER(MATCH($C6;'Room Reservation'!$K$2:$K$6000;0));ISNUMBER(MATCH($D6;'Room Reservation'!$J$2:$J$6000;0)));"محجوزة";"غير محجوزة ")) Hotel Reservation Daily000 (1).xlsm

هناك اكثر من طريقة لعمل ذلك وهذه واحدة منها ..... افتح الاستعلام ولاحظ .... test (8) (1).accdb

تفضل ..... 2.accdb

احسنت اخي علي انا دائما اشجع على الاكواد البرمجية ديناميكية وسريعة واتمنى من الاعضاء طالما وجدوا الحل عدم الاشترطات في الحلول الاساتدة هم من يحددوا ما اذاكان بالمعادلة او الكود

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

وهذا حل ايضا بالكود على الرغم انك قد رافض هذا الأمر من البداية فلهذا موضوعك اخذ أكبر من وقته وحجمه فالموضوع ابسط من هذا بكثير -تفضل وذلك من خلال وضع هذا الكود بحدث الصفحة Private Sub Worksheet_Change(ByVal Target As Range) Dim xCellColumn As Integer Dim xTimeColumn As Integer Dim xRow, xCol As Integer Dim xDPRg, xRg As Range xCellColumn = 1 xTimeColumn = 2 xRow = Target.Row xCol = Target.Column If Target.Text <> "" Then If xCol = xCellColumn Then Cells(xRow, xTimeColumn) = Now() Else On Error Resume Next Set xDPRg = Target.Dependents For Each xRg In xDPRg If xRg.Column = xCellColumn Then Cells(xRg.Row, xTimeColumn) = Now() End If Next End If End If End Sub الحضور1.xlsm

بعد اذن اخي محمد جرب المرفق تشغيل استعلام تحديث و اظهر تنبيه.accdb

Sub Export_Specific_Sheets_To_One_Workbook_Using_Arrays() Dim ws As Worksheet Dim sSheets() As String Dim n As Long Application.ScreenUpdating = False For Each ws In Worksheets(Array("انسولين الهيئة", "انسولين الطلاب والرضع", "تقارير الاصناف")) n = n + 1 ReDim Preserve sSheets(1 To n) sSheets(n) = ws.Name Next ws Worksheets(sSheets).Copy Application.DisplayAlerts = False ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\Output", FileFormat:=51 Application.DisplayAlerts = True ' ' For Each ws In ActiveWorkbook.Worksheets ' ws.UsedRange.Value = ws.UsedRange.Value ' Next ws For Each ws In ActiveWorkbook.Worksheets ws.Unprotect 123 ws.UsedRange.Value = ws.UsedRange.Value ws.Protect 123 Next ws ActiveWorkbook.Close True Application.ScreenUpdating = True MsgBox "Done...", 64 End Sub تم تعديلالكود بواسطة الاستاذ ياسر خليل جزاه الله خيرا وتم المطلوب والحمد لله وهذا الجزء هو ماتم تعديله For Each ws In ActiveWorkbook.Worksheets ws.Unprotect 123 ws.UsedRange.Value = ws.UsedRange.Value ws.Protect 123 Next ws

تم معالجة الامر posting.xlsm

يبدو انك نسيت ان تضغط على ctrl+shift+enter لانها معادلة مصفوفة لذلك لم تعمل معك تفضل إدراج الاسماء تلقائي.xlsx

اهلا بك فى منتدى الاكسس اخى خليل برجاء فتح موضوع جديد ووضح ما تريد مع مثال فعلى لما لديك حتى يتثنى لاخوانك واساتذتنا مساعدتك ومبدئيا لانقاص شهرين من التاريخ انشئ استعلام وبه حقل التاريخ وفى حقل جديد فالاستعلام ضع الكود التالى ثم شغل الاستعلام بدل اسم حقل التاريخ dDate الى الاسم الذى لديك DateAdd("m";-2;[dDate]) بالتوفيق

تم معالجة الامر الكود 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

تفضل أخي Set myRange = ws.Range("c2", ws.Range("c2").End(xlDown)) Set myList = New Collection On Error Resume Next Me.ListBox1.Clear For Each myCell In myRange.Cells If myCell = ComboBox1.Value Then myList.Add myCell.Offset(0, -1).Value, CStr(myCell.Offset(0, -1).Value) End If Next myCell On Error GoTo 0 For Each myVal In myList Me.ListBox1.AddItem myVal Next myVal End Sub '----------------------------------------- Private Sub UserForm_Initialize() Dim myList As Collection Dim myRange As Range Dim ws As Worksheet Dim myVal As Variant Set ws = ThisWorkbook.Sheets("stock") Set myRange = ws.Range("c2", ws.Range("c2").End(xlDown)) Set myList = New Collection On Error Resume Next Me.ComboBox1.Clear For Each myCell In myRange.Cells myList.Add myCell.Value, CStr(myCell.Value) Next myCell On Error GoTo 0 For Each myVal In myList Me.ComboBox1.AddItem myVal Next myVal End Sub المصنف2.xlsm