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

وعليكم السلام ورحمة الله تعالى وبركاته لجلب الصور دفعة واحدة يكفي الوقوف بمؤشر الماوس على اول خلية فارغة على عمود الصور وتشغيل الكود التالي مع تحديد الصور المرغوب اظافتها Sub InsertMultiplePictures() 'اظافة الصور' Set WS = Sheets("ادخال البيانات") Dim Pictures() As Variant Dim j As String, Rng As Range, Cpt As Shape On Error Resume Next Pictures = Application.GetOpenFilename(j, MultiSelect:=True) a = Application.ActiveCell.Column If IsArray(Pictures) Then Col = Application.ActiveCell.Row For lLoop = LBound(Pictures) To UBound(Pictures) Set Rng = Cells(Col, a) Set Cpt = WS.Shapes.AddPicture(Pictures(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height) Col = Col + 1 Next End If End Sub لافراغ عمود الصور Sub DeleteImage() Dim pic As Picture Set f = Sheets("ادخال البيانات") For Each pic In WS.Pictures If Not Application.Intersect(pic.TopLeftCell, f.Range("G6:G200")) Is Nothing Then pic.Delete End If Next pic End Sub الجدول 1 =INDEX('ادخال البيانات'!$B$6:$G$2000;MATCH('طبع البيانات'!$C$10;'ادخال البيانات'!$B$6:$B$2000;0);6) =MyPicture الجدول 2 =INDEX('ادخال البيانات'!$B$6:$G$2000;MATCH('طبع البيانات'!$C$36;'ادخال البيانات'!$B$6:$B$2000;0);6) =MyPicture2 واخيرا ربط الصور بالنطاق الجمعيه الخيريه 2.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته Private Sub TextBox1_Change() Dim a As Variant, b As Variant, Clé$, Rng As Range, i&, j&, k&, m& Dim WS As Worksheet: Set WS = Worksheets("donnes") Dim desWS As Worksheet: Set desWS = Worksheets("search") Clé = "*" & desWS.[B3].Value & "*" Set Rng = desWS.Range("A6:G" & Rows.Count) a = WS.Range("D5", WS.Range("J" & Rows.Count).End(3)).Value If Me.TextBox1 = "" Then Rng.ClearContents Else Application.ScreenUpdating = False With desWS On Error Resume Next .AutoFilterMode = False ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2)) For i = 1 To UBound(a, 1) For j = 1 To UBound(a, 2) 'Filter by Uppercase and lowercase letters If LCase(a(i, j)) Like Clé Or UCase(a(i, j)) Like Clé Then k = k + 1 For m = 1 To UBound(a, 2) b(k, m) = a(i, m) Next Exit For End If Next Next Rng.ClearContents: Range("A6").Resize(k, UBound(b, 2)).Value = b Range("d6:d" & Rows.Count).NumberFormat = "dd-mm-yyyy" End With End If Application.ScreenUpdating = True End Sub بحث VBA V2.xlsm

السلام عليكم ورحمة الله وبركاته أسعد الله أوقاتكم بكل خير وسرور .. وتقبل الله منا ومنكم صالحات الأعمال .. 😊🤲🏻 يطيب لي أن أقدم لكم هذا الهدية المتواضعة بمناسبة هذا الشهر الفضيل 🙂🌼🎁 استبدل الرسائل العادية في أكسس برسائل ذات تصاميم قمة في الإبداع وبمميزات إضافية . من مميزات هذه الرسائل: - تصميم جميل وألوان جذابة. - خاصية ذاتية الاختفاء. - عنوان رئيسي + عنوان فرعي - تحكم بالنص ( عربي - إنجليزي ) ( توسيط - محاذاة على اليمين أو اليسار) - سهلة الاستخدام . الشرح على اليوتيوب : التحميل 🙂 Moosak MsgBox.accdb ولا تنسوني من صالح دعواتكم 😊🌷🌼🌹

اخوي مازن .. تصفحت المثال فتعجبت من طريقتك في استخلاص البيانات اعتقد لم يسبقك احد الى هذه الافكار في التقرير اولا : لماذا العشرات من مربعات التحرير .. وفي مصدر بيانات كل مربع عمليات عجيبة من التصفيات والمعايير كل هذا من اجل اخراج احصائية . المسألة ايسر واسهل من هذا بكثير ثانيا : لن تتقدم خطوة واحدة في تحصيلك البرمجي ما دامت هذه طريقة تصميمك للجداول (تسمية الجداول والحقول بحروف عربية / ترك مسافات خالية في التسميات ) الحروف العربية تكتب فقط في التسميات التوضيحية سوف تتعب كثيرا ولن تفهم الجمل البرمجية المكتوبة .. لأن الترتيب المنطقي للسطر يتداخل في بعضه ) ______________________________ انا هذا منهجي كمعلم .. النصيحة اولا ثم تأتي المساعدة لاحقا بالنسبة لطلبك لامانع لدي ان اخرج تقريرك كما تحب ولكن قبل هذا يجب ان اغير الحروف العربية في المصدر . وسترى الفرق بطريقة جديدة عليك ما رأيك ؟

لماذا لم يفتح عندى ويقول ان الاوفيس المستخدم احدث من الاوفيس الحالى فانا كما تعلم استاذى العزيز انا استخدم اوفيس 2010 فاذا كان المرفق احدث لماذا لايفتح فى اوفيس 2010 جزاك الله خير

بعد الإفطار إن شاء الله أخي الكريم..

كلامك سليم 100000 % ، كل العذر منك استاذنا @سامي الحداد ، ولكني فعلاً لم اقم بتجربة المرفق وكنت اتصفح من الجوال هذا دليل ان الواحد مع التعب يحس الاسلاك في مخه تعمل ماس

هلا بالشباب هذا هو نفس البرنامج الوسيط الذي استخدمته انظروا لمشاركتي السابقة لقد عملت فيديو والملف المرفق مع الاكواد.

يمكنك استخدام هذه الصفحة أيضا للبحث عن المواضيع من خلال عناوينها أو اسم الكاتب : https://officena.net/team/mas/access.html 🙂

شكرا لكم جميعا أيها الأخوة

هاهو اخى انت وضحته لى بارك الله فيك

اطرح الحل هنا اخي الكريم حتى يستفيد منه الجميع 🤗

تم حل المشكل بارك الله فيك اخي الكريم

اضغط على قاعدة البيانات زر الماوس اليمين واختر UNLOCK .

لتقييد البحث بنص محدد أعتقد أنه يجب وضع النص الذي تود البحث عنه بين علامتي تنصيص ، جرب البحث عن النص "" تنسيق حقل فى نموذج بناء على قيمه حقل اخر ستجد الكثير من النتائج ، وجرب هكذا "تنسيق حقل فى نموذج بناء على قيمه حقل اخر" ستجد انه جاء بهذا الموضوع حصراً 🤗

الحــــــل : 1- تعديل الحقول من خصائص الجداول من مربع تحرير وسرد الى مربع نص 2- اعادة استدعاء حقل النص في خانة السرد والتحرير بالنموذج تحياتي اخي واستاذي @Moosak🌹 4444.accdb

هذا موضوع اخر اخي الغالي قم بفتح موضوع بالطلب الجديد

استاذ @سيد تيمي. حاول ترسل القاعدة

يسعدنا اننا استطعنا مساعدتك 😁 بالنسبة للماكرو يمكنك حدفه لا علاقة له بالمطلوب

ربما لم تنتبه للكود اذا اردت الاشتغال على ورقة 2 قم بتعديل هذا السطر لان البيانات يتم جلبها من ورقة 1 Set WS = Worksheets("Sheet1"): Set desWS = Worksheets("Sheet2") الى Set WS = Worksheets("Sheet2"): Set desWS = Worksheets("Sheet2") او تعديله بالكامل بالشكل التالي Option Explicit Public Sub TransposeData2() Dim desWS As Worksheet, rng As Variant Dim Cpt() As Variant, I As Long, J As Long, k As Long, loc As String Set desWS = Worksheets("Sheet2") Application.ScreenUpdating = False rng = desWS.[C6:O10].Value2 For I = 2 To UBound(rng) For J = 2 To UBound(rng, 2) Step 2 If rng(I, J) > 0 Then ReDim Preserve Cpt(2, k + 1) Cpt(0, k) = rng(I, 1) Cpt(1, k) = rng(I, J) k = k + 1 End If Next J Next I If k > 0 Then desWS.Range("C15:D" & Rows.Count).ClearContents desWS.Cells(15, 3).Resize(k, 2).Value = Application.Transpose(Cpt) 'اظافة الجدول loc = desWS.Range("C14:D" & desWS.[D65000].End(xlUp).Row).Address If desWS.ListObjects.Count <> 0 Then Exit Sub desWS.Cells(14, 3).Resize(, 2).Value = Array("Part", "INDEX") desWS.ListObjects.Add(xlSrcRange, desWS.Range(loc), , xlYes).Name = _ "Table1" End If Application.ScreenUpdating = True End Sub

ما فهمت منك لحد الساعة هو انك تريد فلترة ونسخ الصفوف مع الارتباط من ورقة Data الى الورقة النشطة تلقائيا بشرط وجود اسم الورقة في الخلية G2 ادا كان هدا هو طلبك ضع اولا الصيغة التالية في الخلية G2 على جميع الاوراق المرغوب نسخ البيانات عليها للتاكد من مطابقة الاسم يمكنك حدفها بعد دالك =MID(@CELL("filename";A1);FIND("]";@CELL("filename";A1))+1;31) وفي حدث Private Sub Worksheet_Activate ضع الكود التالي Private Sub Worksheet_Activate() Dim lRow2 As Long Set WS = Sheets("data"): Set dest = ActiveSheet If WS.AutoFilterMode Then WS.AutoFilterMode = False lRow2 = WS.Range("A" & Rows.Count).End(xlUp).Row Application.ScreenUpdating = False On Error Resume Next If dest.[G2].Value = dest.Name Then With WS.Range("A2:E" & lRow2) .AutoFilter Field:=5, Criteria1:=dest.[G2].Value Set Rng = WS.Range("A2:E" & lRow2).SpecialCells(xlCellTypeVisible) If Rng.Cells.Count > 1 Then With dest.Range("A2:F" & Rows.Count) .ClearContents: .Interior.ColorIndex = 0: .Borders.LineStyle = xlNone End With Rng.Copy dest.Range("A1") End If .AutoFilter End With End If On Error GoTo 0 End Sub TEST V2.xlsm

Test after 2 days تجربة v2.xlsm

تفضل جرب هدا Option Explicit Private Sub Workbook_Open() Call IncrementDailyOpenCounter(UpdateCell:=Sheet1.[a1]) End Sub Private Sub IncrementDailyOpenCounter(ByVal UpdateCell As Range) On Error Resume Next Debug.Assert [DateStamp] If Err Then Call Me.Names.Add("DateStamp", Date, False) GoTo Update End If If Date > [DateStamp] Then Me.Names("DateStamp").Value = CLng(Date) GoTo Update End If Exit Sub Update: UpdateCell = UpdateCell + 1& Me.Save End Sub تجربة v2.xlsm

Sub TEST1() Dim WordApp As Object, objDoc As Object, Fname As Variant Dim WSdst As Worksheet: Set WSdst = ThisWorkbook.Sheets("word") WSdst.Cells.Clear Fname = Application.GetOpenFilename("Word Documents, *.doc*") If Fname = False Then Exit Sub On Error Resume Next Set WordApp = CreateObject("Word.Application") Set objDoc = WordApp.Documents.Open(Fname) WordApp.Selection.WholeStory WordApp.Selection.Copy WSdst.Range("A1").Select ActiveSheet.Paste With WSdst .Cells.EntireRow.AutoFit: .Columns("A:A").ColumnWidth = 15: '<- قم بتنسيق الورقة بما يناسبك .Columns("A:D").HorizontalAlignment = xlCenter: .Columns("B:E").ColumnWidth = 31 End With objDoc.Close False WordApp.Quit Set WordApp = Nothing Set objDoc = Nothing End Sub في حالة الرغبة باختيار صفحات معينة اليك الكود التالي Sub ImportWordTablesArray() Dim tables() As Variant Dim WordApp As Object, WordDoc As Object Dim arrFile As Variant, Filename As Variant Dim Table As Integer, iCol As Integer Dim iRow As Long, Cpt As Long, Counter As Long Dim WSdst As Worksheet: Set WSdst = ThisWorkbook.Sheets("word") On Error Resume Next arrFile = Application.GetOpenFilename("ملف وورد (*.doc; *.docx),*.doc;*.docx", 2, _ "اظافة الملف", , True) If Not IsArray(arrFile) Then Exit Sub Application.ScreenUpdating = False Set WordApp = CreateObject("Word.Application") WordApp.Visible = False WSdst.Cells.Clear '<- '<-افراغ البيانات السابقة For Each Filename In arrFile Set WordDoc = WordApp.Documents.Open(Filename, ReadOnly:=True) With WordDoc Table = WordDoc.tables.Count If Table = 0 Then MsgBox WordDoc.Name & "لا يحتوي على جداول", vbExclamation, "استيراد" End If tables = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24) '<- '<- ارقام الصفحات For Counter = LBound(tables) To UBound(tables) With .tables(tables(Counter)) For iRow = 1 To .Rows.Count For iCol = 0 To .Columns.Count Cells(Cpt, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text) Next iCol Cpt = Cpt + 1 Next iRow End With Cpt = Cpt + 1 With WSdst .Cells.EntireRow.AutoFit: .Columns("A:b").AutoFit: '<- قم بتنسيق الورقة بما يناسبك .Columns("A:D").HorizontalAlignment = xlCenter: .Columns("c:e").ColumnWidth = 31 End With Next Counter .Close False End With Next Filename WordApp.Quit Set WordDoc = Nothing Set WordApp = Nothing End Sub WORD.rar

العفو اخي يسعدنا اننا استطعنا مساعدتك 😄

وعليكم السلام ورحمة الله تعالى وبركاته Sub test() LastSheet = Sheets.Count Sheets("نمودج").Copy after:=Sheets(LastSheet) End Sub نسخ و اعادة التسمية Sub test2() Dim F As Variant LastSheet = Sheets.Count On Error Resume Next Sheets("نمودج").Copy after:=Sheets(LastSheet) F = InputBox(prompt:="أكتب إسم الورقة الجديد", _ Title:="إعادة تسمية ورقة " & " " & ActiveSheet.Name) ActiveSheet.Name = F End Sub 'قم بتعديله بما يناسبك Sub test3() LastSheet = Sheets.Count On Error Resume Next Sheets("نمودج").Copy after:=Sheets(LastSheet) ActiveSheet.Name = Sheets("TEST").Range("c4").Value End Sub نمودج.xlsb

Public Property Get WS() As Worksheet: Set WS = Feuil1 End Property Sub Hide_Columns() col = "F:G" On Error Resume Next WS.Columns(col).Hidden = True msg = InputBox("أدخل كلمة المرور", "كلمة المرور") If msg = "1234" Then WS.Columns(col).Hidden = False Else If MsgBox("كلمة المرور غير صحيحة، حاول مرة أخرى", Yes Or No, "كلمة مرور خاطئة") = Yes Then WS.Columns(col).Hidden = True On Error GoTo 0 End If End If End Sub '************************** Sub Hide_Rows() Xrows = "13:14" On Error Resume Next WS.Rows(Xrows).Hidden = True msg = InputBox("أدخل كلمة المرور", "كلمة المرور") If msg = "1234" Then WS.Rows(Xrows).Hidden = False Else If MsgBox("كلمة المرور غير صحيحة، حاول مرة أخرى", Yes Or No, "كلمة مرور خاطئة") = Yes Then WS.Rows(Xrows).Hidden = True On Error GoTo 0 End If End If End Sub إخفاء اعمدة وصفوف برقم سري.xlsb

Sub Test_Meragr_Celle() 'دمج Dim LastRow As Long Dim i As Long Application.ScreenUpdating = False Application.DisplayAlerts = False With ActiveSheet LastRow = .Range("c" & .Rows.Count).End(xlUp).Row For i = LastRow To 2 Step -1 If .Range("c" & i).Value = .Range("c" & i - 1).Value Then Application.Union(.Range("c" & i).MergeArea, .Range("c" & i - 1)).Merge End If Next i End With Application.DisplayAlerts = False Application.ScreenUpdating = True End Sub '********************************* Sub annulation_Meragr_Celle() ' الغاء الدمج Dim Rng As Range, xCell As Range Set WorkRng = Range("c2:c" & Cells(Rows.Count, 3).End(xlUp).Row) Application.ScreenUpdating = False Application.DisplayAlerts = False For Each Rng In WorkRng If Rng.MergeCells Then With Rng.MergeArea .UnMerge .Formula = Rng.Formula End With End If Next Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub اختبار.xlsb

Calendar.mdb

يلا شباب بدي ردود سأضع بين أيديكم أكثر من 3000 برنامج بس بدي تشجيعكم BackUpWithCompact2k.zip