بحث مخصص من جوجل فى أوفيسنا
Custom Search
|
-
Posts
1,579 -
تاريخ الانضمام
-
تاريخ اخر زياره
-
Days Won
123
محمد هشام. last won the day on ديسمبر 12
محمد هشام. had the most liked content!
السمعه بالموقع
2,192 Excellentعن العضو محمد هشام.
- حاليا يستعرض موضوع : تكرار اكسل
- تاريخ الميلاد 23 يون, 1986
البيانات الشخصية
-
Gender (Ar)
ذكر
-
Job Title
السلام عليكم
-
البلد
المغرب
-
الإهتمامات
تكنولوجيا
اخر الزوار
10,617 زياره للملف الشخصي
-
وعليكم السلام ورحمة الله تعالى وبركاته بإستخدام الأكواد يمكنك تجربة هدا Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo ExitApp Application.EnableEvents = False Dim tmp() As Variant, ColArr As Variant, lastRow As Long, _ UnitsArr As Variant, i As Long, j As Integer, tbl As String Dim srcWS As Worksheet: Set srcWS = Me If Not Intersect(Target, Me.Range("I:L")) Is Nothing Then UnitsArr = Array("م²", "سهم", "قيراط", "فدان") With srcWS lastRow = .Columns("I:L").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If lastRow < 10 Then Exit Sub ColArr = .Range("I10:L" & lastRow).Value ReDim tmp(1 To lastRow - 9, 1 To 1) For i = 1 To UBound(ColArr, 1) tbl = "" For j = 1 To 4 If IsNumeric(ColArr(i, j)) And ColArr(i, j) > 0 Then tbl = tbl & IIf(tbl <> "", " و ", "") & ColArr(i, j) & " " & UnitsArr(j - 1) End If Next j tmp(i, 1) = tbl Next i With .Range("M10:M" & lastRow) .Value = tmp .ReadingOrder = xlRTL End With End With End If ExitApp: Application.EnableEvents = True End Sub مساحة.xlsb
-
ترقيم تلقائي لا يتأثر بحذف أي صف من الصفوف و متابعة الترقيم
محمد هشام. replied to algammal's topic in منتدى الاكسيل Excel
For tmp = 6 To Irow If IsNumeric(SrcWS.Cells(tmp, "A").Value) Then SrcWS.Cells(tmp, "A").ClearContents End If Next tmp مطلوب ترقيم تلقائى لا يتأثر بحذف الصفوف.xlsb -
هل تقصد حساب عدد الخلايا التي تحتوي على خليط من نصوص وأرقام مثلا 1م3 او T5 جرب هدا Option Explicit Function CalculerVal(rng As Range) As Long Dim cnt As Range, tmp As Long tmp = 0 For Each cnt In rng If cnt.Value <> "" Then If IsNumeric(cnt.Value) Or cnt.Value Like "*[0-9]*" Then tmp = tmp + 1 End If End If Next cnt CalculerVal = tmp End Function في الخلية التي تريد أن تظهر فيها النتيجة مع تعديلها بما يتناسب مع بياناتك الأصلية =CalculerVal(B2:H2) مجموع الأرقام مع الحروف.xlsb
-
وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Private Const Clé As String = "1234" ' قم بتعديل الباسوورد بما يناسبك Private Sub Worksheet_Change(ByVal Target As Range) Dim lastRow As Long lastRow = Cells(Rows.Count, "J").End(xlUp).Row ActiveSheet.Unprotect Clé If Not Intersect(Target, Me.Range("J7:J" & lastRow)) Is Nothing And Target.Columns.Count = 1 Then Application.EnableEvents = False Dim cell As Range For Each cell In Target If cell.Row >= 7 Then cell.Locked = Not IsEmpty(cell.Value) Next cell Application.EnableEvents = True End If ActiveSheet.Protect Clé, UserInterfaceOnly:=True End Sub '================================== Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim lastRow As Long, choose As String: Static OnRng As Range lastRow = Cells(Rows.Count, "J").End(xlUp).Row If Not Intersect(Target, Me.Range("J7:J" & lastRow)) Is Nothing Then If Not IsEmpty(Target.Value) Then If Target.Locked Then choose = InputBox(": خلية التوقيع محمية الرجاء إدخال كلمة المرور", ":إنتــباه") If choose = Clé Then ActiveSheet.Unprotect Clé If Not OnRng Is Nothing Then OnRng.Locked = True Target.Locked = False Set OnRng = Target ActiveSheet.Protect Clé, UserInterfaceOnly:=True ElseIf choose <> "" Then MsgBox "كلمة المرور غير صحيحة", vbExclamation, "خطأ" End If Else Set OnRng = Target End If Else ActiveSheet.Unprotect Clé Target.Locked = False Set OnRng = Nothing ActiveSheet.Protect Clé, UserInterfaceOnly:=True End If End If End Sub شيت حوافز تجريبى V2.xlsb
- 1 reply
-
- 2
-
ترقيم تلقائي لا يتأثر بحذف أي صف من الصفوف و متابعة الترقيم
محمد هشام. replied to algammal's topic in منتدى الاكسيل Excel
ماذا تقصد بصفحات أخرى؟ هل أوراق عمل أخرى أو جداول جديدة في نفس الورقة ؟ اذا كنت تقصد جداول فهذا ما يفعله الكود عند إظافة جدول يتضمن نفس الشروط حاول تحديد و نسخ أي جدول بداية من صف عناوين الأعمدة إلى غاية صف المختص ونسخه أسفل الجداول السابقة ستلاحظ تحديث الترقيم تلقائيا -
ترقيم تلقائي لا يتأثر بحذف أي صف من الصفوف و متابعة الترقيم
محمد هشام. replied to algammal's topic in منتدى الاكسيل Excel
وعليكم السلام ورحمة الله تعالى وبركاته صراحة أخي @algammal التعامل مع الملف باستخدام المعادلات لتنفيذ طلبك غير عملي خصوصا أنك ترغب في إمكانية الترقيم التلقائي عند حذف أو إضافة صفوف جديدة أو حتى جدول جديد ما يزيد من التعقيد هو وجود العديد من الخلايا المدمجة والصفوف الفارغة على عمود الترقيم أعتقد أن الحل الأنسب هنا هو استخدام الأكواد مجرد إقتراح ربما يناسبك الكود التالي يعمل بشكل ديناميكي ويتعرف تلقائيا على الجداول بناءا على كلمات مفتاحية تحدد بداية الجدول ونهايته قمت بتحديدها نظرا لشكل تصميمك للملف حيث يقوم الكود بالبحث عن كلمة "الاسم" في عمود B للتعرف على بداية الجدول ومن ثم يبحث عن كلمة "المختص" في نفس العمود لتحديد نهاية الجدول وبمجرد تحديد نطاق الجدول سيقوم الكود بإعادة الترقيم على الجداول المتواجدة في الملف داخل هذا النطاق في العمود A بداية من الصف 7 إذا قمت بتغيير هذه الكلمات المفتاحية عليك تعديلها داخل الكود أيضا لذلك ييفضل أن تحرص دائما على وجود هذه الكلمات في أماكنها لتضمن عمل الكود بشكل صحيح Private Sub Worksheet_Change(ByVal Target As Range) Dim SrcWS As Worksheet, Irow As Long, tmp As Long, n As Long, OnRng As Long, tbl As Long, i As Long Const StarTBL As String = "الاسم" Const EndTBL As String = "المختص" On Error GoTo ErrorData Set SrcWS = Me Irow = SrcWS.Cells(SrcWS.Rows.Count, "B").End(xlUp).Row SetApp False For tmp = 6 To Irow If Not SrcWS.Cells(tmp, "A").MergeCells Then SrcWS.Cells(tmp, "A").ClearContents Next tmp n = 1 tmp = 6 Do While tmp <= Irow If Trim(SrcWS.Cells(tmp, "B").Value) = StarTBL Then OnRng = tmp + 1 Do While Trim(SrcWS.Cells(tmp, "B").Value) <> EndTBL And tmp <= Irow tmp = tmp + 1 Loop tbl = tmp - 3 For i = OnRng To tbl If Not SrcWS.Cells(i, "A").MergeCells And SrcWS.Cells(i, "A").Value = "" Then SrcWS.Cells(i, "A").Value = n n = n + 1 End If Next i End If tmp = tmp + 1 Loop SetApp True Exit Sub ErrorData: End Sub Private Sub SetApp(ByVal Enable As Boolean) Application.ScreenUpdating = Enable Application.EnableEvents = Enable Application.Calculation = IIf(Enable, xlCalculationAutomatic, xlCalculationManual) End Sub مطلوب ترقيم تلقائى لا يتأثر بحذف الصفوف.xlsb -
Sub test() Dim wsSource As Worksheet, wsPass As Worksheet Dim lastRow As Long, i As Long, passRow As Long Set wsSource = Sheets("Sheet1") Set wsPass = Sheets("Sheet2") Application.ScreenUpdating = False Irow = wsPass.Cells(wsPass.Rows.Count, "G").End(xlUp).Row For j = 4 To Irow Step 2 wsPass.Range("A" & j & ":N" & j).ClearContents Next j lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row passRow = 4 For i = 3 To lastRow If InStr(1, LCase(wsSource.Cells(i, "G").Value), "1/6") > 0 Then wsPass.Cells(passRow, 1).Resize(1, 14).Value = wsSource.Cells(i, 1).Resize(1, 14).Value wsPass.Cells(passRow, 1).Value = passRow - 3 wsPass.Cells(passRow, 1).NumberFormat = wsSource.Cells(i, 1).NumberFormat passRow = passRow + 2 End If Next i Application.ScreenUpdating = True End Sub test.xlsb
-
وعليكم السلام ورحمة الله تعالى وبركاته لست متأكدا مما تحاول فعله جرب هدا Sub test() Dim wsSource As Worksheet, wsPass As Worksheet Dim lastRow As Long, i As Long, passRow As Long, Rng As Range Set wsSource = Sheets("Sheet1") Set wsPass = Sheets("Sheet2") Application.ScreenUpdating = False lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row passRow = 4 For i = 3 To lastRow If InStr(1, LCase(wsSource.Cells(i, "G").Value), "1/6") > 0 Then wsPass.Cells(passRow, 1).Resize(1, 14).Value = wsSource.Cells(i, 1).Resize(1, 14).Value wsPass.Cells(passRow, 1).Value = passRow - 3 wsPass.Cells(passRow, 1).NumberFormat = wsSource.Cells(i, 1).NumberFormat passRow = passRow + 2 If Rng Is Nothing Then Set Rng = wsSource.Cells(i, 1).Resize(1, 14) If Not Rng Is Nothing Then Set Rng = Union(Rng, wsSource.Cells(i, 1).Resize(1, 14)) End If Next i If Not Rng Is Nothing Then Rng.ClearContents Application.ScreenUpdating = True End Sub لحدف الصفوف If Not Rng Is Nothing Then Rng.Delete Shift:=xlUp End If
-
وعليكم السلام ورحمة الله تعالى وبركاته لتحديد حجم كل منتج مع لونه يمكنك استخدام الصيغة التالية =SUMPRODUCT(($B$2:$B$8=$B11)*($C$2:$C$8=C$10)*($D$2:$J$8)) مع سحبها يسارا والى للاسفل على حسب احتياجاتك مجرد اقتراح يمكنك أيضا استخراج مجموع كل آلة بشكل منفصل حسب اختيارك للحصول على مزيد من التفاصيل وعند اختيار الخيار "الكل" سيتم عرض مجموع جميع الآلات يمكن القيام بذلك باستخدام الصيغة التالية بعد إضافة قائمة منسدلة تحتوي على أسماء رؤوس الأعمدة الموجودة في الجدول =IF($O$10="الكل", SUMPRODUCT(($B$2:$B$8=$M12)*($C$2:$C$8=N$11)*($D$2:$J$8)), IFERROR(SUMIFS(INDEX($D$2:$J$8, 0, MATCH($O$10, $D$1:$J$1, 0)), $B$2:$B$8, $M12, $C$2:$C$8, N$11), 0)) هدا سيمكنك من استخراج النتائج بعدة طرق يمكنك اختيار ما يناسبك زيرو 2.xlsx
-
وعليكم السلام ورحمة الله تعالى وبركاته يمكنك استخدام الكود التالي من المصنف الرئيسي وتحديث ملفات الإدارة دفعة واحدة بدون فتحها او تغيير تنسيقها يكفي وضعها في نفس مسار المصنف بحيث يتم تحديث البيانات عند التحقق من عدم وجود الرقم التأميني مسبقا على ملف الإدارة الهدف وتحديث عمود (م) وإظافة تاريخ التحديث في عمود ( تاريخ دخول القسم) Option Explicit Sub Departments_update() Dim WB As Workbook, destWB As Workbook, srcWS As Worksheet, destWS As Worksheet, _ iRow As Long, Rng As Range, dstRng As Long, lastRow As Long, Cnt As String, _ tmp As String, n As String, WSname As String, ShArr As Variant, j As Boolean, _ Updated As Boolean, nameFile As String, cell As Range, result As Boolean ShArr = Array("المستحقين", "احياء", "التفتيش", "اخرى") Cnt = "=SUBTOTAL(103,INDIRECT(ADDRESS(ROW(),COLUMN()+1)&"" :""&ADDRESS(ROW($E$7),COLUMN()+1)))" Updated = False result = False Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual Application.EnableEvents = False: Application.DisplayAlerts = False Set WB = ThisWorkbook For Each srcWS In WB.Worksheets If Not IsError(Application.Match(srcWS.Name, ShArr, 0)) Then WSname = srcWS.Name nameFile = WB.Path & "\" & WSname & ".xls" If Dir(nameFile) <> "" Then result = True Set destWB = Workbooks.Open(nameFile) Set destWS = destWB.Worksheets(WSname) If Not destWS Is Nothing Then For iRow = 7 To srcWS.Cells(srcWS.Rows.Count, "R").End(xlUp).Row n = srcWS.Cells(iRow, "R").Value If InStr(1, n, WSname, vbTextCompare) > 0 And n <> "" Then tmp = srcWS.Cells(iRow, "E").Value j = False lastRow = destWS.Cells(destWS.Rows.Count, "E").End(xlUp).Row For Each cell In destWS.Range("E7:E" & lastRow) If cell.Value = tmp Then j = True Exit For End If Next cell If Not j Then Set Rng = srcWS.Range(srcWS.Cells(iRow, 3), srcWS.Cells(iRow, 27)) dstRng = destWS.Cells(destWS.Rows.Count, "E").End(xlUp).Row + 1 If dstRng < 7 Then dstRng = 7 destWS.Cells(dstRng, "C").Resize(, 25).Value = Rng.Value destWS.Cells(dstRng, "D").Value = Date destWS.Cells(dstRng, "B").Formula = Cnt Updated = True End If End If Next iRow destWB.Close SaveChanges:=True Else destWB.Close SaveChanges:=False End If Set destWB = Nothing Set destWS = Nothing End If End If Next srcWS If result Then MsgBox IIf(Updated, "تم تحديث البيانات بنجاح", "جميع البيانات محدثة مسبقا"), vbInformation, "تعليمات" Else MsgBox "لم يتم العثور على أي ملفات خاصة بالإدارات", vbExclamation, "تنبيه" End If Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True: Application.DisplayAlerts = True Set WB = Nothing: Set srcWS = Nothing: Set Rng = Nothing: Set cell = Nothing End Sub ملفات الإدارة.rar ترحيل الصفوف مع عدم التكرار.rar
-
قمت بتجربة الملف يشتغل معي بدون أدنى مشكلة على العموم جرب هدا Sub SrcWS(WSname As String) Dim WS As Worksheet, tmp As Boolean tmp = False SetApp False For Each WS In ThisWorkbook.Worksheets If WS.Name = WSname Then tmp = True: Exit For Next WS For Each WS In ThisWorkbook.Worksheets: WS.Visible = xlSheetVisible Next WS For Each WS In ThisWorkbook.Worksheets: If WS.Name <> WSname Then WS.Visible = xlSheetVeryHidden Next WS Sheets(WSname).Activate SetApp True End Sub Sub GoToMain() SrcWS "الرئيسية " End Sub Sub GoToWS1() SrcWS "كشف التلامي الحاضرين صفحة 1" End Sub Sub GoToWS2() SrcWS "كشف التلامي الحاضرين صفحة 2" End Sub Sub GoToWS3() SrcWS "الدخول و الخروج خلال الشهر" End Sub Sub GoToWS4() SrcWS "المعلومات العامة" End Sub Private Sub SetApp(ByVal Enable As Boolean) On Error Resume Next Application.ScreenUpdating = Enable Application.EnableEvents = Enable Application.Calculation = IIf(Enable, xlCalculationAutomatic, xlCalculationManual) End Sub كشف التلاميذ الحاضرين 2023--2024.xlsb
-
وعليكم السلام ورحمة الله تعالى وبركاته بعد إدن الأستاد @عبدالله بشير عبدالله تفضل جرب هدا بدون الحاجة لتغيير أسماء أوراق العمل Option Explicit Sub test() Dim Sh As Worksheet, WS As Worksheet: Set WS = Worksheets("واردالمنطقة") Dim iRow As Long, Rng As Range, dstRng As Long, lastRow As Long, Cnt As String, Updated As Boolean Dim tmp As String, j As Boolean, cell As Range, WSname As String, ky As String, n As String Cnt = "=SUBTOTAL(103,INDIRECT(ADDRESS(ROW(),COLUMN()+1)&"" :""&ADDRESS(ROW($E$7),COLUMN()+1)))" Updated = False Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False For Each Sh In ThisWorkbook.Worksheets If Sh.Name <> WS.Name Then WSname = Sh.Name: ky = Replace(WSname, "ال", "") For iRow = 7 To WS.Range("R" & WS.Rows.Count).End(xlUp).Row n = WS.Cells(iRow, "R").Value If InStr(1, n, ky, vbTextCompare) > 0 And n <> "" Then tmp = WS.Cells(iRow, "E").Value j = False For Each cell In Sh.Range("E7:E" & Sh.Rows.Count) If cell.Value = tmp Then j = True Exit For End If Next cell If Not j Then Set Rng = WS.Range(WS.Cells(iRow, 2), WS.Cells(iRow, 28)) dstRng = Sh.Cells(Sh.Rows.Count, "E").End(xlUp).Row + 1 If dstRng < 7 Then dstRng = 7 Sh.Cells(dstRng, "B").Resize(, 27).Value = Rng.Value Sh.Cells(dstRng, "D").Value = Date lastRow = Sh.Cells(Sh.Rows.Count, "B").End(xlUp).Row Sh.Cells(lastRow, "B").Formula = Cnt Updated = True End If End If Next iRow End If Next Sh MsgBox IIf(Updated, "تم ترحيل البيانات بنجاح", "جميع البيانات محدثة مسبقا"), vbInformation, "تعليمات" Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True End Sub ترحيل الصفوف مع عدم التكرار بتحقق شرط v2.rar
-
وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Const Main As String = "الرئيسية " Sub destination(WSname As String) Dim WS As Worksheet, f As Worksheet, srcWS As Worksheet Set srcWS = Sheets(Main) Application.ScreenUpdating = False For Each WS In ThisWorkbook.Worksheets If WS.Name = WSname Then Set f = WS Exit For End If Next WS On Error Resume Next For Each WS In ThisWorkbook.Worksheets If WS.Name <> WSname Then WS.Visible = xlSheetVeryHidden Next WS On Error GoTo 0 f.Visible = xlSheetVisible: f.Activate If srcWS.Visible = xlSheetVisible And WSname <> Main Then srcWS.Visible = xlSheetVeryHidden Application.ScreenUpdating = True End Sub Sub GoToMainSheet() Sheets(Main).Visible = xlSheetVisible destination Main End Sub Sub GoToPage1() destination "كشف التلامي الحاضرين صفحة 1" End Sub Sub GoToPage2() destination "كشف التلامي الحاضرين صفحة 2" End Sub Sub GoToPage3() destination "الدخول و الخروج خلال الشهر" End Sub Sub GoToPage4() destination "المعلومات العامة" End Sub وفي حدث ThisWorkbook Private Sub Workbook_Open() Dim WS As Worksheet Const srcWS As String = "الرئيسية " For Each WS In ThisWorkbook.Worksheets WS.Visible = IIf(WS.Name = srcWS, xlSheetVisible, xlSheetHidden) Next WS End Sub كشف التلاميذ الحاضرين 2023--2024.xlsb
-
اخي هدا ما يفعله الكود فعلا بعد تعديلك للسطر المشار إليه LastRow = 45 اي عدد الصفوف لديك على الملف او تثبيتها هنا مباشرة WS.Range(WS.Cells(4, tmp), WS.Cells(45, tmp)).Interior.Color = RGB(255, 255, 0) جدول الحصص الإضافية 3.xlsb