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

نرحب بالأخ صالح البريكان (أبو آمنة) فى فريق الموقع🌼 أهلا وسهلا بك أخي الكريم ، و تقبل الله جهودك و جهود باقي الأخوة فى نشر العلم و المعرفة

تفضل اخي الكريم Dim fso As Object Dim fldrname As String Dim fldrpath As String Dim MyFolderName As String MyFolderName= "عنصر التحكم او اسم المجلد" Set fso = CreateObject("scripting.filesystemobject") fldrpath = CurrentProject.Path & "\" & MyFolderName If Not fso.FolderExists(fldrpath) Then fso.createfolder (fldrpath) End If

و عليكم السلام و رحمة الله وبركاته جرب توريد للمخزن في المرفق لعله المطلوب Sub ADDIN01() Dim FS As Worksheet, TS As Worksheet Dim Q1 Set FS = Sheets(ActiveSheet.Name) Set TS = Sheets("المخزن") For FR = 5 To 30 Q1 = FS.Cells(FR, 6).Value Q2 = FS.Cells(FR, 4) & "*" & FS.Cells(FR, 5) Q3 = FS.Cells(FR, 7).Value For TR = 3 To 999 If TS.Cells(TR, 2) = Q1 Then For TC = 3 To 33 If TS.Cells(2, TC) = Q2 Then TS.Cells(TR, TC) = TS.Cells(TR, TC) + Q3 GoTo 9 End If Next 'TC End If Next 'TR 9 Next ' FR End Sub المخزنAZ.xlsm

تفضل هذا التعديل بناء على تعديل اخي ازهر test (1).accdb

هذا الكود يدرج لك القوائم المنسدلة Option Explicit Sub data_val() Dim Fatura As Worksheet, Price As Worksheet Dim Dic As Object Dim lr%, i% Set Fatura = Sheets("فواتير") Set Price = Sheets("الأسعار") Set Dic = CreateObject("Scripting.Dictionary") lr = Price.Cells(Rows.Count, 1).End(3).Row i = 2 With Price Do Until i > lr If .Cells(i, 1) <> vbNullString Then Dic(.Cells(i, 1).Value) = vbNullString End If i = i + 1 Loop End With With Fatura.Cells(5, 1).Resize(15).Validation .Delete .Add 3, Formula1:=Join(Dic.keys, ",") End With End Sub الملف مرفق samihkhader.xlsm

مش تفكير بس ... فنجان قهوة .. بارك الله فيك .. بالتوفيق

لا تنتظر المساعدة من احد بدون رفع ملف مدععوم بشرح كافى عن المطلوب ... حيث لا يمكن العمل على التخمين وتجنباً لعدم اهدار وإضاعة وقت الأساتذة دون جدوى او أهمية !!!!! وبما انك لم تقم برفع ملف فتفضل هذا به طلبك كيف تستخدم خاصية Go to Special لتحديد خلايا معيّنة في

السلام عليكم ورحمة الله اجعل هذا الكود هكذا Sub KH_Paste(MySheet As Worksheet, KRow As Integer) On Error Resume Next With MySheet .Range("A" & KRow).PasteSpecial xlPasteValues .Range("A" & KRow).PasteSpecial xlPasteFormats If .Name = "ناجحين" Then .Range("A" & KRow) = KRow - 9 Else .Range("A" & KRow) = KRow / 2 - 4 End If End With Application.CutCopyMode = False End Sub كشف درجات الصف الثاني الابتدائي_5.xls

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

اليا لم افكر فيه ... يستحق التفكير فية لكن استخدم التوثيق كما في الصور

هل غيرت اسم الجدول والحقل هنا Private Sub Command6_Click() DeleteDuplicateRecords "tbl1", "Fname" End Sub

مبروك لنا و لكم و للجميع هذا الانسان الراقي أبو آمنة أخوك / د.كاف يار ( حسين كمال )

جرب الملف المرفق monzer 2 (1).xlsx

للتنويه : يمكن عمل ذلك باكثر من طريقة مثلا تعمل جدول مشابه للجدول الاساسي وتجعل حق الاسم مطلوب .. التكرار لا ثم تعمل استعلام الحاق من الجدول الاساسي للجدول الجديد . فيتم استبعاد الاسماء المكررة ... وهكذا

هذا واجب علينا للمنتدى واعضائه حياك الله اخي الكريم

جرب المرفق وخبرنا بالنتيجة ..... fouad.accdb

تفضل يمكنك جعل المعادلة هكذا ... وتم عمل أيضاً تنسيق شرطى للخلية اذا كان بها كلمة مغادرة =IF(G$7=$D8,"مغادرة",IF(AND(G$7>=$C8,G$7<=$D8-1),$E8,0)) If Function.xlsx

@husamwahab, @Shivan Rekany كلمة شكر لاتكفي لكن دعوة بالغيب ,,,,,,

ليس من الضروري ادراج الكثير من الصفوف يكفي نموذج بسيط (20- 30) صف Ammaro.xlsx

try this file WiAAM.xlsx

يمكن الاستعانة بهذه المعادلة =IF(COUNTIF(A4:A10; F4:F10 );"";F4:F10) ملف الاسم.xlsx

ABO.xlsm

May be? الصيغة الاصلية للكشف البنكي.xlsm

و هذا ملف يمكنك منه خلاله الاختيار دمج الخلايا او عدم دمجها زر لكل اختيار (على 3 أعمدة (يمكن الاضافة قدر ما تريد) Option Explicit Sub Unmerg_cells() Application.ScreenUpdating = False If ActiveSheet.Name <> "Test" Then GoTo End_Me Dim lr#, i# Dim My_rg As Range, x, y, z, n Dim My_min lr = Cells(Rows.Count, "A").End(3).Row For i = 2 To lr If Cells(i, 1).MergeCells Then x = Cells(i, 1) y = Cells(i, 2) z = Cells(i, 3) n = Cells(i, 1).MergeArea.Rows.Count Cells(i, 1).UnMerge Cells(i, 1).Resize(n) = x Cells(i, 2).UnMerge Cells(i, 2).Resize(n) = y Cells(i, 3).UnMerge Cells(i, 3).Resize(n) = z i = i + n - 1 End If Next End_Me: Range("A1").Select Application.ScreenUpdating = True End Sub '++++++++++++++++++ Sub merge_all() Application.ScreenUpdating = False If ActiveSheet.Name <> "Test" Then GoTo End_Me Dim k% For k = 1 To 3 Call One_for_all(k) Next With Range("A1").CurrentRegion .Font.Size = 14 .Font.Bold = True End With End_Me: Range("A1").Select Application.ScreenUpdating = True End Sub '+++++++++++++++++++++++++++++++++++++ Sub One_for_all(ByVal Col As Integer) Application.DisplayAlerts = False Dim i%, lr%, My_rg As Range Dim x lr = Cells(Rows.Count, Col).End(3).Row Set My_rg = Cells(1, Col) For i = 1 To lr x = Cells(i, Col).Value If My_rg.Cells(1).Value = x Then Set My_rg = Union(My_rg, Cells(i, Col)) My_rg.MergeCells = True Else Set My_rg = Cells(i, Col) End If Next Application.DisplayAlerts = True End Sub الملف مرفق Merge_Unmerge_rows_Multiple_colmns.xlsm

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