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

In cell D1 type the number 666 then in cell D4 put the formula ="Shatbeyya "&($D$1+5*(ROW()-4))&"-"&($D$1+4+5*(ROW()-4))

تفضل كود نسخ البيانات.xlsm

السلام عليكم .. عملتلك نفس المثال الذي ارفقته يبقى عليك التحسينات لو انك عامل رقم تسلسلي للاصناف كان افضل Database3.rar

مرحبا تريد رد ولا تريد ارفاق ملف 😱😱 ستتم الاجابة ايضا بلا ملف ومن واقع تخمين فقط يمكنك ازالة اخر سطر اذا كنت لا تريد مسح التيكست بوكس Private Sub TextBox1_Change() If Left(TextBox1.Text, 1) = "K" Then MsgBox "هذا الحرف موجود بالفعل" End If TextBox1.Text = "" End Sub

دالة لتجمع القيم وإجراء لتوزيع القيم Sub SplitValues() Dim Box As Byte For Box = 1 To 5 Me.Controls("chk" & Box) = Mid(Me.moreinfo, Box, 1) * -1 Next Box End Sub Function JoinValues() Dim Box As Byte For Box = 1 To 5 JoinValues = JoinValues & Abs(Nz(Me.Controls("chk" & Box), 0)) Next Box End Function

تفضل Private Sub cmdsave_Click() Dim c1, c2, c3, c4, c5, cc As String Dim numinfo As String cc = "00" If Me.chk1 = True Then c1 = "1" Else c1 = "0" If Me.chk2 = True Then c2 = "1" Else c2 = "0" If Me.chk3 = True Then c3 = "1" Else c3 = "0" If Me.chk4 = True Then c4 = "1" Else c4 = "0" If Me.chk5 = True Then c5 = "1" Else c5 = "0" If Not IsNull(Me.txtfasthrs) Then cc = Me.txtfasthrs Else cc = "00" numinfo = Format(c1 & c2 & c3 & c4 & c5 & cc, "0000000") Me.moreinfo = numinfo With rs .AddNew ![pname] = txtpname ![moreinfo] = numinfo .Update End With lstData.Requery End Sub ManyCheckboxValues3.rar

تم حذف المرفقات ..

أخي الكريم من الخطاء جعل حقل رقم الموظف ترقيم تلقائي لانك ستواجه مشاكل كثيرة في ال TempVars من خلال ال Dlookup. اليك هذا التعديل في اكواد المودولات Emp_Var و Module2 ' Emp_Var Module Option Compare Database Option Explicit Public Sub EmpNameVar() Dim EmpNameTemp As Variant If Not IsNull([TempVars]![EmpIdTemp]) And [TempVars]![EmpIdTemp] <> "" Then Dim empId As Long empId = CLng([TempVars]![EmpIdTemp]) EmpNameTemp = DLookup("[emp_name]", "[tblName]", "[emp_code]=" & empId) TempVars.Add "EmpNameTemp", EmpNameTemp End If End Sub Public Function Totalcountt() As Integer Dim x As Integer x = DCount("[emp_code]", "tblName", "[job_Status]=1") Totalcountt = x End Function ' Module2 Option Compare Database Option Explicit Function TotalVac() Dim db As DAO.Database Dim rs As DAO.Recordset Dim rs1 As DAO.Recordset Dim rs2 As DAO.Recordset Dim CountRecord As Integer Dim i, s As Integer Set db = CurrentDb If Not IsNull([TempVars]![EmpIdTemp]) Then Dim empId As String empId = "'" & CStr([TempVars]![EmpIdTemp]) & "'" Set rs = db.OpenRecordset("SELECT * FROM tblVacation WHERE (((tblVacation.EmpCode) = " & empId & " AND (tblVacation.VacationLife) = 'سارية')) ORDER BY vacationstartdate Asc;") Set rs1 = db.OpenRecordset("SELECT * FROM tblVacation WHERE (((tblVacation.EmpCode) = " & empId & " AND (tblVacation.VacationLife) = 'سارية')) ORDER BY vacationstartdate Asc;") On Error Resume Next db.TableDefs.Delete "vac" On Error GoTo 0 Dim strSQL As String strSQL = "SELECT * INTO vac FROM tblVacation " & _ "WHERE (((tblVacation.EmpCode) = " & empId & " AND (tblVacation.VacationLife) = 'سارية')) " & _ "ORDER BY vacationstartdate ASC;" db.Execute strSQL rs.Close Set rs = Nothing rs1.Close Set rs1 = Nothing Else ' (يمكنك إظهار رسالة أو تنفيذ أي إجراء آخر حسب الحاجة) End If Set db = Nothing End Function تأخرت عليك بالرد لان الوقت عندي متقدم بستة ساعات عن وقت الدول العربية. بالتوفيق الكل.rar

Sub Export() 'تعريف المتغيرات Dim WshtNames As Variant Dim WshtNameCrnt As Variant Dim Rang1 As Range Dim wk As Worksheet Dim nsh As String Dim wk_Row, wk1_Row, r As Integer 'تحميل متغير الورقة الرئيسية Set wk = Worksheets("الرئيسية") 'تحميل متغير صفوف البيانات في الورقة الرئيسية wk_Row = 10000 'تحميل متغير نطاق البيانات في الورقة الرئيسية Set Rang1 = wk.Range("C6:C" & wk_Row) 'تحميل متغير اورق المراد الإرسال لها WshtNames = (Array("الأول", "الثاني", "الثالث", "الرابع", "الخامس", "السادس", "السابع")) 'مسح البيانات السابقة For Each WshtNameCrnt In WshtNames With Worksheets(WshtNameCrnt) wk1_Row = .Range("B10000").End(xlUp).Row .Range("B3:c" & wk1_Row + 1) = "" End With Next 'عمل حلقة تكرار بعدد صفوف البيانات في الورقة الرئيسية For r = 6 To wk_Row 'تحميل متغير التفضيلات بعد حذف منصرف ليتناسب مع الورقة المرسل لها nsh = Trim(Mid(wk.Range("C" & r), 6, Len(wk.Range("C" & r)))) 'حلقة تكرار الاورق المراد الإرسال لها For Each WshtNameCrnt In WshtNames ' مقارنة بند التفضيلات مع ورقة العمل If Worksheets(WshtNameCrnt).Name = nsh Then ' في حال انطبق اشرط ارسال بند التفضيلات إلى ورقة العمل With Worksheets(WshtNameCrnt) wk1_Row = .Range("B10000").End(xlUp).Row .Range("B" & wk1_Row + 1) = wk.Range("C" & r) .Range("C" & wk1_Row + 1) = wk.Range("G" & r) End With End If Next Next 'اضافة المجموع For Each WshtNameCrnt In WshtNames With Worksheets(WshtNameCrnt) wk1_Row = .Range("B10000").End(xlUp).Row .Range("B" & wk1_Row + 1) = "المجموع" .Range("c" & wk1_Row + 1) = "=SUM(C3:C" & wk1_Row & ")" End With Next End Sub

باقي المجاميع ما أدري تريدها إجمالي أو متوسط نسبة التحصيل العلمي للطلاب.xlsb

وجدت لك مثالا يحتوي على اربع طرق للترقيم التلقائي داخل الاستعلام Sequence: DCount("AuID";"Authors";"AuID <=" & [AuID]) '..................................... Sequence: DCount("AuName";"Authors";"AUName <='" & [AuName] & "'") '.................................... Sequence: (Select Count(1) FROM Authors A WHERE A.AuID <=Authors.AuID) '.................................... Sequence: (Select Count(1) FROM Authors A WHERE A.AuName <=Authors.AuName) NumberedQuery2k.mdb

وعليكم السلام ورحمة الله تعالى وبركاته تفضل جرب Sub compter() Dim i& Dim sh As Worksheet: Set sh = Worksheets("ورقة1") a = [j2] b = [k2] On Error Resume Next For i = a To b If IsNumeric(b) = True And a >= 1 Then [A1] = a Application.Wait (Now + TimeValue("00:00:03")) a = a + 1 Else Exit Sub End If Next i On Error GoTo 0 End Sub

من أهم أساسيات قواعد البيانات يجب عمل عمود يحتوي على رقم هذا السجل في قاعدة البيانات

جزاكم الله خيراً. هل يمكن تنفيذ نفس الهدف ولكن بحيث يستقي الماكرو قائمتي الكلمات من شيت إكسيل أو قاعدة بيانات أكسيس ؟ أحسن الله إليكم ونفع بكم.

اعرض الملف كود لقلب وضعية بلوكات كاملة طلب مني زميل حل لعكس ترتيب مجموعة من بلوكات البيانات من الوضعية الافقية الي الوضع الرأسي و ذلك دون تغيير وضعية البيانات داخل البلوك الواحد ، كما هو مبين فى الضورة يمتاز الكود بعدم مجدودية عدد البلوكات (يتم الاختيار طبقا للتظليل) و يمكن تعديله بسهولة ليناسب اعداد الاعمدة المختلفة داخل البلوك و ذلك يتعديل قيمة متغير واحد فى الكود. و لكي تستخدم هذا الكود قم اولا بتحديد عدد الأعمدة داخل كل بلوك عن طريق المتغير CC فى الكود و فى المثال هنا عدد أعمدة كل بلوك هو 3 ـ و يمكنك تغييره كما تشاء ثم قم بتظليل كافة البيانات المراد تغيير وضعها على أن تكون عدد الاعمدة المختارة من مضاعفات الرقم المختار لأعمدة كل بلوك ثم شغل الكود Sub PivotBlocks_arafa() Dim r, c, b As Integer Dim g As String cc = 3 ' قم بتعديل هذا الرقم لتغيير عدد الاعمدة الافتراضي فى البلوك الوحد r = Selection.Rows.Count c = Selection.Columns.Count b = c / cc g = ActiveCell.Address For x = 1 To b - 1 Range(ActiveCell.Offset(0, cc * x), ActiveCell.Offset(r - 1, cc * x + cc - 1)).Cut ActiveCell.Offset(r * x - 1 + 1, 0).Activate ActiveSheet.Paste Range(g).Activate Next x End Sub صاحب الملف محمد طاهر تمت الاضافه 07 يول, 2020 الاقسام قسم الإكسيل  

نعم ، هناك عدة طرق منها: تفتح شيت جديد، ثم عن طريق أمر دمج في تبويبة البيانات تعمل اضافة للجداول (اختيارك للجدول في الشيت الأول سيتكرر بنفس التحديد ، مجرد تختار الشيت الثاني وتعمل اضافة وهكذا، ثم يخرج لك جدول واحد بالتوفيق

حرب هذا الملف Option Explicit Sub Get_Color() Dim My_Regex As Object Dim x%, m%, La%, t% Dim arrWords, Arr() ReDim Arr(4) Arr(0) = 3: Arr(1) = 14: Arr(2) = 5: Arr(3) = 3 Set My_Regex = CreateObject("VBScript.RegExp") My_Regex.Pattern = "(\d{3})" My_Regex.Global = True With Sheets("Sheet1") La = .Cells(Rows.Count, 3).End(3).Row m = 1 With .Range("E6:E" & La) .Font.ColorIndex = 1 .ClearContents End With For t = 6 To La .Range("E" & t) = .Range("C" & t) If My_Regex.test(.Range("E" & t)) Then Set arrWords = My_Regex.Execute(.Range("E" & t)) For x = 0 To arrWords.Count - 1 Range("E" & t).Characters(m, 3) _ .Font.ColorIndex = Arr(x) m = m + 3 Next x End If m = 1 Next t End With End Sub الملف مرفق Abbadi.xlsm

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

تفضل أخي الحبيب في الملف المرفق قمت بتسمية نطاقات ديناميكية أي أنه لن تحتاج إلى تغيير النطاق في المعادلات كل ما عليك هو إضافة بنود جديدة وسيتم ظهور النتائج في الحال New Group.rar

آمين جرب هذا Private Sub ButtonSaveFil_Click() Dim iC As Integer iC = Me.ListFind.ListCount If iC = 0 Then GoTo 1 '------------------------ Application.ScreenUpdating = False With Sheets(3) .Select .Range("A6").Resize(.UsedRange.Rows.Count, .UsedRange.Columns.Count).ClearContents .Range("A6").Resize(iC, ContColmn).Value = Me.ListFind.List End With Application.ScreenUpdating = True Unload Me 1 End Sub تحياتي

استبدل بدلا من الرقم 1000 الطول الحقيقي للكشف عندك Private Sub ButtonSaveFil_Click() Dim iC As Integer iC = Me.ListFind.ListCount If iC = 0 Then GoTo 1 '------------------------ Application.ScreenUpdating = False With Sheets(3) .Select .Range("A6").Resize(1000, ContColmn).ClearContents .Range("A6").Resize(iC, ContColmn).Value = Me.ListFind.List End With Application.ScreenUpdating = True Unload Me 1 End Sub تحياتي فتح الله لك ، واعطاك من كل الخيرات التي تتمناها ، ولكن اريد توسع اكثر ، فهم رقم 1000 ، واريد ان يكون الملف مفتوحا ، وليس محددا بمدى معين ، اي كل مستند ، وليس 1000 صف او عمود فقط ، كل المستند

أخي العزيز / أحمد غانم اظن السبب هو نوعية الحساب حيث تم حفظ الملف على الحساب اليدوي يمكنك تغير الحساب من يدوي إلى تلقائي وإن شاء الله يكون مضبوط جرب واعلمني بالنتيجة وهذا الملف أرفقه مرة أخرى بعد تعديل نوعية الحساي إلى تلقائي والعفو افراد الهيئة التعليمية1.rar

في الوقت الذي قمت فيه بوضع الرد على السؤال كنت في عجلة من أمري ولم أتأكد من أن القيم التي تم سردها هي القيم المتكررة فقط أو أكثر من ذلك .. على كل حال تم إضافة التعديل المطلوب على الصيغ .. وبالإضافة إلى ذلك قمت بكتابة الكود التالي ليقوم بفرز القيم المتكررة نيابة عن خمس أعمدة من الصيغ .. فأختر من الطريقتين ما يناسبك. Private Sub Worksheet_Change(ByVal Target As Range) TC = Target.Column TR = Target.Row If TC = 1 And TR > 1 And TR < 23 Then Set MyRange = [C2:C22] Application.ScreenUpdating = False MyRange.ClearContents For R = 2 To 22 If Application.WorksheetFunction.CountIf([A2:A22], Cells(R, 1)) > 1 Then With Columns(3).Rows(65536).End(xlUp) .Offset(1, 0) = Cells(R, 1) End With End If Next For Each Cell In MyRange If Application.WorksheetFunction.CountIf(MyRange, Cell) > 1 Then Cell.ClearContents End If Next MyRange.Sort [C2], xlAscending Application.ScreenUpdating = True End If End Sub شاهد المرفق، _______________________________________.rar