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

تفضل أخي test2.xlsx

السلام غليكم شكرا لحضرتك kkhalifa1960 ربنا يجعلو فى ميزان حسناتك

، الصورة التي أرفقتها تُظهر 4 أزرار في مربع الحوار، وهو شيء غير ممكن عند استخدام MsgBox مباشرة في VBA، حيث يدعم MsgBox فقط حتى 3 أزرار كحد أقصى.

تفضل استاذ @alaa111 المرفق بعد التعديل بطلبك .وولفني بالرد . Microsoft Access قاعدة بيانات جديد-111 ‫‬.rar

جزاك الله خيرا

أحسنت أستاذ محمد وبارك الله فيك وجزاك الله خير الثواب .. وهذا بالفعل هو المطلوب .اللهم وسع فى رزقك وفرج عنك كربات يوم القيامة ويكرمك الله فى الدارين هل يمكن ربط معادلة SUMIFS أيضا بأرقام الصف كما بالمعادلة السابقة ؟ ولكم جزيل الشكر

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا مع سحب المعادلة للأسفل =IFERROR(INDEX(INDIRECT("Sheet1!A" & $J$2 & ":A" & $K$2); MATCH(0;COUNTIF($B$1:B2; INDIRECT("Sheet1!A" & $J$2 & ":A" & $K$2)) + IF(INDIRECT("Sheet1!A" & $J$2 & ":A" & $K$2) = ""; 1; 0); 0)); "") في حالة إستخدامك لنسخة أوفيس حديثة =IFERROR(UNIQUE(INDIRECT("Sheet1!A" & $J$2 & ":A" & $K$2)); "")

قد أتيت به فعلاً .. و والله لضيق الوقت لم استطع رفع الملف .. Desktop.zip

لم أصر ّ على ذلك، و إنما هذا البرنامج إنتهيت منه و عليه تركت الأمر على حاله، أما فيما يخص توجيهاتك القيمة السابقة فهي في الحسبان، في برنامجي الجديد إن شاء الله ، فأطمئن و ليرتح بالك . وشكراً على ما تمّ تقديمه من شخصك.

ممكن مشاركة مع الاساتذة .... تفضل استاذ @sm44ms برنامج يقوم بجلب البطاقة واستقطاع الصورة وعملها شفافة . تفضل الشرح والبرنامج بالمرفقات . ووافني بالرد . تفضل البرنامج نزله من الموقع التالي وسطبه ولا تذهب للتحديث . https://www.phoxo.com/en/download/

استاذ ابو حمادة صندوق الاوامر في اكسل الافتراضيه لا تدعم اكثر من امرين الى 3 اوامر فقط وهي:- vbOKCancel (موافق - إلغاء) vbYesNoCancel (نعم - لا - إلغاء) vbAbortRetryIgnore (إيقاف - إعادة المحاولة - تجاهل) vbYesNo (نعم - لا) vbRetryCancel (إعادة المحاولة - إلغاء) إذا كنت بحاجة إلى أكثر من ثلاثة أزرار، يمكنك إنشاء UserForm يحتوي على أربعة أزرار او اكثر مخصصة لتنفيذ الأوامر التي تريدها. ويمكنك تسمية الازرار باي اسم شاهد الملف بواسطة UserForm اوامر userform.xlsb

تفضل 🙂 : ( وأرفقت لك المربع الشفاف بشكل منفصل أيضا) 🙂 Transpharnt Picture.zip هات ما عندك 😎✌

وعليكم السلام و رحمة الله و بركاته سبب المشكلة عدم وجود متغير tmp . hg و اليك الكود بعد تعديل Sub Copy_Transfer_WORD() Dim WS As Worksheet Dim Rng As Range, j As Range, Irow As Range Dim x As Long, r As Long, lastRow As Long Dim i As Integer, Ary As Variant Dim Cnt() As String Dim arr() As String Dim tmp As Range Set WS = Sheets("الانشطة") lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row Application.DisplayAlerts = False Application.ScreenUpdating = False Msg = MsgBox("؟" & " " & "Word " & ":" & " تصدير التقرير بصيغة", vbYesNo, WS.Name) If Msg <> vbYes Then Exit Sub n.Visible = xlSheetVisible: n.Cells.UnMerge Set tmp = n.Range("A1:l" & n.Rows.Count) Cnt() = Split("A-A,D-C,E-D,F-E,G-F,H-G,I-H,J-I", ","): tmp.Clear For i = 0 To UBound(Cnt) arr = Split(Cnt(i), "-") Set Rng = n.Range(arr(1) & n.Rows.Count).End(xlUp) WS.Range(arr(0) & "4:" & arr(0) & lastRow).Copy Destination:=Rng Next i rngA = Split("C", ","): rngB = Split("B", ",") For i = LBound(rngA) To UBound(rngA) WS.Range(rngA(i) & "4:" & rngA(i) & lastRow).Copy With n.Range(rngB(i) & "1") .PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False End With Next i n.Columns("A").SpecialCells(xlBlanks).EntireRow.Delete lr = n.Cells(n.Rows.Count, "A").End(xlUp).Row Set A = n.Rows(1): Set b = n.Rows(2): Set d = n.[A1:I1]: Set E = n.Range("A3:I" & lr) A.RowHeight = 75: b.RowHeight = 40: b.Font.Bold = True: b.Font.Size = 14 d.Merge: d.Interior.Color = RGB(192, 192, 192) n.[A2:I2].Interior.Color = RGB(215, 238, 247): n.[H2:I2].Merge E.Interior.ColorIndex = xlNone: E.Font.Name = "AdvertisingBold": E.Font.Size = 13 F = n.Cells(2, n.Columns.Count).End(xlToLeft).Column + 1 n.Range(n.Cells(2, 1), n.Cells(lr, F)).Borders.Weight = xlThin Ary = Array(5, 15, 38, 38, 38, 15, 15, 15, 15) For x = 0 To UBound(Ary) n.Columns(x + 1).ColumnWidth = Ary(x) Next x Set Irow = n.Range("A3", n.Cells(n.Rows.Count, "A").End(xlUp)) For Each j In Irow.Rows If j.RowHeight < 20 Then: j.RowHeight = 30: Else j.EntireRow.AutoFit Next n.Range("b3:b" & n.Rows.Count).NumberFormat = "yyyy/mm/dd" n.Range("A:I").EntireColumn.HorizontalAlignment = xlCenter n.Range("A:I").EntireColumn.VerticalAlignment = xlCenter With n.Range("A3:A" & n.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-2") End With WS.Activate: ExcelToWordSheet1 n.Visible = xlSheetVeryHidden Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub

وعليكم السلام ورحمة الله وبركاته 🙂 أعمل مربع أو مستطيل في برنامج الباوربوينت ، وغير الشفافية إلى الرقم الذي يناسبك .. ولا تنسى تغير الخلفية للون الأبيض .. بعد كذا تحفظ المستطيل كصورة بصيغة PNG وتفتحها في الأكسس وتخليها فوق صورة الموظف .. وبكذا بيكون درجة وضوح صورة الموظف خفيفة ..

وعليكم السلام ورحمة الله وبركاته أخي @بوكفوس عبدالسلام .. بما انك تصر على استخدام مسميات عربية وهذا يعني انك مصمم على المضي في طريق عدم اكتساب المعلومة الصحيحة .. اجعل مصدر كل تقرير = الجدول أو الحقول التي تريدها مع تحديد الشرط بحيث يكون الشرط واقع ضمن تحديد حقل الرقم = مربع النص Texte256 وعلى حسب ما فهمت هو حقل الرقم للسجل ، وإلا فعدل الشرط بتغيير مربع النص والحقل للمفتاح الأساسي . على العموم هذه فكرتي والتي تجاري فكرتك في انشاء قاعدة البيانات غير الصحيحة :- Hand.zip

في التحديث الجديد ، سيتم الإعتماد على الفكرة المطروحه هنا في هذا الموضوع " رافع ملفات جوجل درايف 2025 " ، لكن مع اختلاف بسيط جزئي سيتم طرحه حال الإنتهاء من التحضير له وضبطه من جميع جوانبه ، تجنباً لأي أخطاء عند الإستخدام .

السلام عليكم ساشرح لك بمثال لنفرض ان الملف 1 به الكود الثالي Sub SortData() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("ورقة1") With ws.Sort .SortFields.Clear .SortFields.Add Key:=ws.Range("I8:I73"), Order:=xlDescending .SetRange ws.Range("A8:AH73") .Header = xlNo .Apply End With End Sub وتريد تقل الكود الى الملف 2 حيث تريد عمود الفرز مثلا العمود M واول صف به بيانات هو الصف 10 واخر صف به بيانات هو الصف 120 واول عمود به بيانات B واخر عمود به بيانات هو العمود BA الخطوات :- تعديل الكود ليتناسب مع التغيرات في الملف 2 السطر في الكود .SortFields.Add Key:=ws.Range("I8:I73"), Order:=xlDescending السطر السابق خاص بالعمود المطلوب فرزه I8 تعنى بداية فرز البيانات الصف 8 للعمود I تهاية الفرز لتفس العمود الصف 73 الان تريد ان تعدل في السطر حسب الملف2 الملف 2 المطلوب عمود الفرز M واول صف به بيانات هو الصف 10 فتكتب بدل M10 -I8 واخر صف 120 فنستبدل M120 - I73 فيكون السطر النهائي .SortFields.Add Key:=ws.Range("M10:M120"), Order:=xlDescending وكذلك يتم التغيير في السطر .SetRange ws.Range("A8:AH73") هذا النطاق يحتوي على جميع الخلايا من العمود A إلى AH ومن الصف 8 إلى 73. ,والملف 2 الخلايا من العمود Bإلى BAومن الصف 10إلى 120. فيصبح SetRange ws.Range("B10:BA120") فيصبح الكود النهائي Sub SortData() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("ورقة1") With ws.Sort .SortFields.Clear .SortFields.Add Key:=ws.Range("M10:M120"), Order:=xlDescending .SetRange ws.Range("B10:BA120") .Header = xlNo .Apply End With End Sub بالتوفيق

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Sub kh_Color1() Dim Obj As Object, MyColor As Long, lr As Long, R As Long, txt As String Dim WS As Worksheet: Set WS = Sheets("قيود اليومية") Application.ScreenUpdating = False Set Obj = CreateObject("Scripting.Dictionary") MyColor = 900000 lr = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row WS.Range("A6:J" & lr).Interior.color = 800444 For R = 6 To lr txt = Trim(WS.Cells(R, "G")) If Len(txt) Then If Not Obj.Exists(txt) Then Obj.Add txt, MyColor MyColor = MyColor + 7000111 End If WS.Range(WS.Cells(R, "A"), WS.Cells(R, "J")).Interior.color = Obj(txt) Dim rColor As Long, gColor As Long, bColor As Long rColor = (Obj(txt) Mod 256) gColor = ((Obj(txt) \ 256) Mod 256) bColor = ((Obj(txt) \ 65536) Mod 256) If (rColor + gColor + bColor) / 3 < 128 Then WS.Cells(R, "A").Resize(1, 10).Font.color = RGB(255, 255, 255) Else WS.Cells(R, "A").Resize(1, 10).Font.color = RGB(0, 0, 0) End If End If Next R Set Obj = Nothing Application.ScreenUpdating = True End Sub

السلام عليكم و رحمة الله استخدم هذا الكود Sub Summing() Dim C As Range, i As Long Dim a As Integer, b As Integer i = 3 Do While i <= 4 a = Range("E" & i): b = Range("F" & i) For Each C In Range("A3:A9") If C.Value >= a And C.Value <= b Then k = k + C.Offset(0, 1) Range("G" & i) = k End If Next k = 0 i = i + 1 Loop End Sub

اعتقد ان الكود الخاص بي يفعل نفس الشيء ينقصه فقط تحديد النطاق المرغوب الاشتغال عليه لعدم دكرك دالك في اول مشاركة يمكنك التحقق من الرابط التالي : https://streamable.com/49qe96 تم تعديل الكود ليتناسب مع طلبك الاخير Sub Find_and_Replace_values() Dim Title As Variant, WS As Worksheet: Set WS = ActiveSheet Dim arr(2) As Variant, WSrng As Range, i As Integer, Cpt As Long Title = Array("البحث", "الاستبدال") i = 0 Do 'قيمة البحث والاستبدال arr(i) = InputBox(" أدخل قيمة " & " " & Title(i), Title(i)) If StrPtr(arr(i)) = 0 Then Exit Sub If Len(arr(i)) = 0 Then MsgBox "يجب عليك إدخال قيمة" & " " & Title(i), 48, "خطأ" Else i = i + 1 End If Loop Until i > 1 On Error Resume Next ' تحديد النطاق Set WSrng = Application.InputBox(Prompt:=" تحديد نطاق البحث: ", _ Title:="البحث والاستبدال", _ Default:=Selection.Address, Type:=8) If WSrng Is Nothing Then Exit Sub WSrng.Replace arr(0), arr(1), xlPart, , False Cpt = WorksheetFunction.CountIf(WSrng, arr(1)) MsgBox " تم إستبدال " _ & Cpt & " قيمة" _ & vbCrLf & vbCrLf _ & " " & "من" & " " & arr(0) & " " & "إلى" & " " & arr(1), vbInformation, "information" End Sub في حالة الرغبة بعدم استبدال الصيغ بصفة عامة والتعامل مع القيم فقط يمكنك استخدام هدا الخيار ''''''''''''''' ' تحديد النطاق Set WSrng = Application.InputBox(Prompt:=" تحديد نطاق البحث: ", _ Title:="البحث والاستبدال", _ Default:=Selection.Address, Type:=8) If WSrng Is Nothing Then Exit Sub For Each c In WSrng If Not c.HasFormula And c <> "" Then c.Replace arr(0), arr(1), xlPart, , False Cpt = WorksheetFunction.CountIf(WSrng, arr(1)) End If Next c MsgBox " تم إستبدال " _ & Cpt & " قيمة" _ & vbCrLf & vbCrLf _ & " " & "من" & " " & arr(0) & " " & "إلى" & " " & arr(1), vbInformation, "information" End Sub Find_and_Replace_FormulaVersion3.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن الاخ ايهاب عبد الحميد جرب الكود التالي Sub Find_and_Replace_values_comments() Dim Title As Variant, WS As Worksheet: Set WS = Sheets("Sheet1") Dim arr(2) As Variant, WSrng As Range, i As Integer, cell As Range Title = Array("البحث", "الاستبدال") i = 0 Do 'قيمة البحث والاستبدال arr(i) = InputBox(" أدخل قيمة " & " " & Title(i), Title(i)) If StrPtr(arr(i)) = 0 Then Exit Sub If Len(arr(i)) = 0 Then MsgBox "يجب عليك إدخال قيمة" & Title(i), 48, "خطأ" Else i = i + 1 End If Loop Until i > 1 On Error Resume Next 'قم بتعديل النطاق بما يناسبك Set WSrng = WS.Range("A1:M100") WSrng.Replace arr(0), arr(1), xlPart, , False For Each cell In WSrng.SpecialCells(xlCellTypeComments) cell.Comment.Text Application.Substitute(cell.Comment.Text, arr(0), arr(1)) Next End Sub في حالة الرغبة في البحث والإستبدال على جميع صفحات المصنف فقد تمت إظافة الكود في الملف المرفق بالتوفيق........... Find_and_Replace_FormulaVersion.xlsb