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

استاذ @ناقل المحترم استبدل Utilities.Restart فقط Restart

وانت في صحة وسلامة طيب انشئ وحدة نمطية وضع هذا فيه ::::::: Private Const TIMEOUT = 99 Public Sub Restart() Dim scriptpath As String scriptpath = Application.CurrentProject.FullName & ".dbrestart.bat" If Dir(scriptpath, vbNormal) <> "" Then If DateAdd("s", TIMEOUT * 1, FileDateTime(scriptpath)) < Date Then Kill scriptpath Else Application.Quit acQuitSaveAll Exit Sub End If End If Dim s As String s = s & "SETLOCAL ENABLEDELAYEDEXPANSION" & vbCrLf s = s & "SET /a counter=0" & vbCrLf s = s & ":CHECKLOCKFILE" & vbCrLf s = s & "ping 0.0.0.255 -n 1 -w 100 > nul" & vbCrLf s = s & "SET /a counter+=1" & vbCrLf s = s & "IF ""!counter!""==""" & TIMEOUT & """ GOTO CLEANUP" & vbCrLf s = s & "IF EXIST ""%~f1.%3"" GOTO CHECKLOCKFILE" & vbCrLf s = s & "start "" "" ""%~f1.%2""" & vbCrLf s = s & ":CLEANUP" & vbCrLf s = s & "del %0" Dim intFile As Integer intFile = FreeFile() Open scriptpath For Output As #intFile Print #intFile, s Close #intFile Dim dbname As String, ext As String, lockext As String Dim idx As Integer For idx = Len(CurrentProject.FullName) To 1 Step -1 If Mid(CurrentProject.FullName, idx, 1) = "." Then Exit For Next idx dbname = Left(CurrentProject.FullName, idx - 1) ext = Mid(CurrentProject.FullName, idx + 1) If Left(ext, 2) = "ac" Then lockext = "laccdb" Else lockext = "ldb" End If s = """" & scriptpath & """ """ & dbname & """ " & ext & " " & lockext Shell s, vbHide Application.Quit acQuitSaveAll End Sub تحت حدث الزر ضع هذا :::::::: Utilities.Restart

دكتورنا العزيز...احتمال فرحان ببدلة العيد والكود مش شغال معاك 😂 كل عام وانت بخير... الكود شغال وزي الفل

تفضل لك ما طلبت .. تـــم تنظيم الملف وعمل قائمة منسدلة بأسماء جميع صفحات الملف.. وهذه هى المعادلة المستخدمة لجلب البيانات من كل صفحة بمعلومية اسم الصفحة =INDIRECT("'"&$A$1&"'!"&CHAR(64+COLUMNS($A$1:A1))&""&ROWS($A$1:A3)) testttt1.xlsx

Sub Test() Dim rng As Range Application.ScreenUpdating = False With ActiveSheet Set rng = .Range("H2:L" & .Cells(Rows.Count, "H").End(xlUp).Row) With rng With .Columns(.Columns.Count) .Formula = "=MATCH(H2,B:B,0)" .Value = .Value rng.Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlYes .ClearContents End With End With End With Application.ScreenUpdating = True End Sub

الكود يعمل بنجاح على الرغم من غرابة السؤال والاغرب منه تصور الافادة من تلك النتيجة قطعا اذا عرف السبب بطل العجب

تفضل التعديل.. بالنسبة للمطلب الثاني لم افهمه واين تكتب المرفقات مساعدات مرضية تعديل 1(1).accdb

As an idea, you can copy the visible cells to unused range then store the range into array Sub Test() Dim a, m As Long With ActiveSheet m = .Cells(Rows.Count, 1).End(xlUp).Row + 10 .Range("A1").CurrentRegion.Offset(1).SpecialCells(xlCellTypeVisible).Copy .Range("A" & m) a = .Range("A" & m).CurrentRegion.Value .Range("A" & m).CurrentRegion.Clear End With End Sub

وعليكم السلام وكل عام وانتم بخير تفضل التعديل الدالة.accdb

حسب معطياتك والكود السابق ...يكون الكود بالشكل التالي بصراحة لم اعمل على السيرفر سابقا ولا يمكنني التاكد اهم شي كود الاتصال تبعك Dim Con_Dest As New ADODB.Connection Dim Rs_Dest As New ADODB.Recordset Dim Str_SqlDest As String Dim Str_Sql As String Con_Dest.Open "dsn=yyyyy;uid=yyyyy;pwd=yyyyyy" Str_SqlDest = "select * from MyTable" Rs_Dest.Open Str_SqlDest, Con_Dest Rs_Dest.MoveFirst Do Until Rs_Dest.EOF With Rs_Dest .AddNew Rs_Dest(0) = Text_id.Value Rs_Dest(1) = Text_Name.Value Rs_Dest(2) = Combobox_City.Value ..... .Update End With Rs_Dest.MoveNext Loop

السلام عليكم ,, مبدأياً يجب اضافة المكتبة الخاصة بالAdo , ثانيا يمكن استخدام الكود التالى للاتصال بالسيرفر Dim conn As ADODB.Connection Dim rs As ADODB.Recordset Dim strConnString As String strConnString = "Provider=SQLOLEDB;Data Source="اسم السيرفر";" _ & "Initial Catalog="اسم قاعدة البيانات";Integrated Security=SSPI;" Set conn = New ADODB.Connection conn.Open strConnString بالنسبة للاستعلامات يمكن استخدام Set rs = conn.Execute(" جملة استعلام Sql",conn) ملاحظة : جملة الاتصال بالسيرفر للاتصالات الآمنة يعنى اذا كان الدخول للسيرفر Mixed او Windows Authentication اما اذا كان الاتصال خارجى يمكن استخدام strConnString = "Provider=SQLOLEDB;Data Source="اسم السيرفر";" _ & "Initial Catalog="اسم قاعدة البيانات";Integrated Security= No ; ID = "username"; Password = "Password" " ملاحظة اخرى : لم استخدم الاكسس للاتصال بالSQL من قبل استخدامى للSQL فى لغات .Net لذلك خبرتى هنا محدودة , بالتوفيق

حل باستخدام اعمدة مساعدة ودالة TEXTJOIN في المرفق test.xlsx

الشكر لله ثم لاخواننا واساتذتنا جزاهم الله عنا كل خير بالتوفيق

فيديوووووو جديددددد كيفية علم ترقيم تسلسلي في البيفوت تيبل في الفيديو دة هانتعلم ازاي نضيف جوة البيفوت تيبل ترقيم تسلسلي زي اللي موجود في الاكسيل https://youtu.be/JexkDt05R20 كيفية عمل ترقيم تسلسلي داخل البيفوت تيبل.xlsx

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

Sub Test() Dim rng As Range, c As Long Application.ScreenUpdating = False Set rng = Range("A5:J" & Cells(Rows.Count, "D").End(xlUp).Row) rng.UnMerge For c = 1 To rng.Columns.Count With rng.Columns(c) On Error Resume Next .SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C" If c = 3 Then .Text = .Text Else .Value = .Value On Error GoTo 0 End With Next c Application.ScreenUpdating = True End Sub

اخى هل ستفوم بتكرار تنفيذ الكود عشر مرات لعشرة اعمدة ناهيك عن ان الكود طويل خليك في المصرى افضل من الاجنبي صناعة مصرية خالصة لوجه الله الكود لعسرة اعمدة مرة واحدة شاهد المرفق Sub UnMerge_Rng() ' Application.ScreenUpdating = False End_Row = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row + 2 For Col = 1 To 10 Set Rng = Range(Cells(5, Col), Cells(End_Row, Col)) With Rng .MergeCells = False .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C" .Value = .Value End With Next Application.ScreenUpdating = True ' End Sub تقرير الطلاب1.xlsb

تفضل كما بالصورة كى تعمل ... أو جرب هذا الكود Sub FFvba() Cells(1, 2) = "123-45-6789" Dim rng As Range Set rng = Range("B1:B4") rng.FlashFill End Sub

هذه تخضع لذوق الكاتب،، وأنا أستخدم للعنوان وتذييل الاسم والتوقيع MCS Jeddah S_U normal. وللسلام DecoType Naskh Variants وللختام DecoType Naskh Swashes وللبيان Khalid Art bold نحو

السلام عليكم ورحمة الله وبركاته أختي الكريمة حسب علمي الضحل الجواب ضمن الملف المرفق =ROUND(AB433*21%;2) دالة تقريب الخلية المذكورة*٢١% إلى رقمين عشريين. =ROUND(IF(CB433>500;500;CB433);2) دالة تقريب إذا كانت الخلية أكبر من 500 أعطني 500 وإن لم تكن أعطني قيمة الخلية ذاتها مقربة إلى رقمين عشريين ياسمين محمد.xlsx

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

اليك الحل باعمدة مساعدة غيرت المعادلات . جرب وان شاء الله يعمل بشكل جيد لكم تحياتي البطاقة المدرسية++.xlsm

اليك هذا الماكرو الذي يدرج لك 4 معادلات قي كافة الصفجات كل واحدة في مكانها المناسب لا وقت لدي لتكملته (تستطيع انت فعل ذلك بنفس الطريقة) الماكرو Option Explicit Sub Salim_Macro() 'هذا الماكرو يدرج 4 معادلات تسطيع ان تكمله لادراج كافة المعادلات Dim Y$ Dim x%, i%, K%: K = Sheets.Count For i = 2 To K x = Sheets(i).Index '===================== fromula in D5========== Y = "='0'!B" & x + 2 Sheets(i).Range("d5") = Evaluate(Y) '===================== fromula in d8========== Y = "=IF('0'!C" & x + 2 & ",'0'!C" & x + 2 & ","""" )" Sheets(i).Range("d8") = Evaluate(Y) '===================== fromula in F10========== Y = "=IF('0'!D" & x + 2 & ",'0'!D" & x + 2 & ","""" )" Sheets(i).Range("f10") = Evaluate(Y) '===================== fromula in M10========== Y = "=IF('0'!E" & x + 2 & ",'0'!E" & x + 2 & ","""" )" Sheets(i).Range("M10") = Evaluate(Y) Next End Sub الملف مرفق اضغط فقط على الزر RUN في الصفجة 0 B6_salim.xls

السلام عليكم يمكن الاضافة و حفظ التعديل لكن في حالة النقص غير ممكن على الاقل لحد الآن **************** اخي kby جزاكم الله خيرا على المرور سيارات 4.rar

اخي يوسف جرب المرفق التالي سيارات 2.rar

الملف لايعمل