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

تفضل اخي In French =SI((LIGNE()-1)<=NBCAR(SUBSTITUE(A$1;" ";""));STXT(SUBSTITUE(A$1;" ";"");LIGNE()-1;1);"") In English =IF((ROW()-1)<=LEN(SUBSTITUTE(A$1;" ";""));MID(SUBSTITUTE(A$1;" ";"");ROW()-1;1);"") فرز.xlsx

أفكار جميلة ورائعة بارك الله فيكم جميعا أحبتي ونظرا لأني أهوى اختصار الأكواد والمعادلات يمكنني تعديل المعادلة إلى في A2 =MID(SUBSTITUTE(A$1," ",""),ROW(A1),1) بالتوفيق

=MID(SUBSTITUTE(A$1;" ";"");ROWS(A$2:A2);1)

Another one using office 365 =LET(x,MID(A1,SEQUENCE(LEN(A1)),1),FILTER(x,SUBSTITUTE(x," ","")<>""))

في زر الامر ضع الكود Dim x As String x = Me.EmpName.Column(1) & ".rtf" DoCmd.OpenReport "Hr_Letter_Rep", acViewPreview, , "[Empcoode]=" & Me.Empcoode DoCmd.OutputTo acOutputReport, "Hr_Letter_Rep", _ acFormatRTF, "d:\" & x, True وبالامكان تغيير مكان الحفظ من الدريف d الى اي قرص HR_Letter.rar

السلام عليكم اهداني اخي العزيز @حسونة حسين ملف اكسل يحتوي على جميع مواضيع منتدى اكسس وبروابط مباشرة اضعه بين ايديكم لا تنسونا من دعوات صالحات *********************** ( إضافات للموضوع - Moosak ) قمت بعمل تصميم بسيط لنموذج البحث وأضفته إلى الموضوع الرئيسي بعد أذن أستاذنا أبو خليل 🙂 بمجرد الكتابة تظهر النتائج .. لاستعراض الموضوع يتم الضغط على العنوان مباشرة النقر المزدوج على مربع البحث يعيد إظهار جميع النتائج 🙂 يمكن البحث بكلمات متفرقة في الجملة .. Search_Officena_Access.rar ********************************************** Access.rar

شكرا لرد حضرتك يا أستاذ محمد أولا : النطاق ليس ثابت ممكن يزيد وممكن يقل ثانيا :نعم أقصد عند كل ترحيل ان تكون البيانات المرحلة دائما في مابين راس الصفحة وزيلها ثالثا: نعم الأوراق ستكون تحت بعضها

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

واثراء للموضوع هذه افكارى المتواضعة working days.accdb

هنا اختلف معك تقدر تجعل الكود يعمل و النموذج مفتوح و ذلك بإلغاء مصدر السجلات و ارجاعه بعد تفعيل او الغاء المفتاح الأساسي من الجدول مرفق التطبيق للفكرة تفعيل وايقاف اضافة سجل للمكرر (2).mdb

Database211.accdb

تفضل اخي بالنسبة للترحيل اليك الكود التالي Sub Transfer() Dim K%, DL2%, S%, Rng As Range Dim WS_data As Worksheet: Set WS_data = ThisWorkbook.Sheets("تسجيل البيعة") Dim WS_dest As Worksheet: Set WS_dest = ThisWorkbook.Sheets("تسجيل المخزون") Application.ScreenUpdating = False K = WS_data.Range("C65500").End(xlUp).Row + 1 If WS_data.Range("C4") = Empty Then: MsgBox "ليس هناك بيانات", 64: Exit Sub If WS_data.Range("D2") = Empty Then: MsgBox "المرجوا ادخال التاريخ", 64: Exit Sub If WS_data.Range("H2") = Empty Then: MsgBox "المرجوا ادخال رقم الفاتورة", 64: Exit Sub With WS_dest DL2 = WS_dest.Range("C65500").End(xlUp).Row + 1 S = DL2 + K - 4 WS_dest.Range("F" & DL2 & ":F" & S) = WS_data.Range("c4:c" & K).Value WS_dest.Range("G" & DL2 & ":G" & S) = WS_data.Range("D4:D" & K).Value WS_dest.Range("H" & DL2 & ":H" & S) = WS_data.Range("E4:E" & K).Value WS_dest.Range("I" & DL2 & ":I" & S) = WS_data.Range("F4:F" & K).Value WS_dest.Range("C" & DL2 & ":C" & S) = WS_data.Range("D2") WS_dest.Range("D" & DL2 & ":D" & S) = WS_data.Range("H2") WS_dest.Range("E" & DL2 & ":E" & S) = WS_data.Range("J2") End With Set Rng = WS_data.Range("C4:I" & K).SpecialCells(xlCellTypeConstants) Rng.ClearContents Application.ScreenUpdating = True End Sub اما بالنسبة لتصفية البيانات يمكنك استخدام هدا الكود Sub BFVB() Dim lastRow As Long, lrow As Long, Article As Range Dim sh As Worksheet: Set sh = ThisWorkbook.Sheets("الشهر") lrow = sh.Range("A" & Rows.Count).End(xlUp).Row + 1 Set Rng = sh.Range("C2") Dim sh2 As Worksheet: Set sh2 = ThisWorkbook.Sheets("تسجيل المخزون") lastRow = sh2.Range("C" & Rows.Count).End(xlUp).Row If Rng.Value = Empty Then MsgBox "المرجو ادخال الصنف": Exit Sub On Error Resume Next Set Article = sh2.Range("G:G").Find(What:=Rng, LookIn:=xlValues, LookAt:=xlWhole) If Not Article Is Nothing Then Application.ScreenUpdating = False sh.Range("A4:G" & lrow).ClearContents sh2.Range("G1").AutoFilter Field:=5, Criteria1:="=" & Rng sh2.Range("C1").AutoFilter Field:=1, _ Criteria1:=">=" & sh.Range("E1").Value2, Operator:=xlAnd, _ Criteria2:="<=" & sh.Range("E2").Value2 With sh2 sh2.Range("C2:I" & lastRow).SpecialCells(xlCellTypeVisible).Copy sh.Range("A4").PasteSpecial xlPasteValues sh.Activate DL = sh.Range("A65500").End(xlUp).Row DC = sh.Cells(3, Columns.Count).End(xlToLeft).Column sh.Range("A3:G100").Borders.LineStyle = xlNone sh.Range(Cells(3, 1), Cells(DL, DC)).Borders.Weight = xlThin On Error GoTo 0 End With Else m = MsgBox("الصنف " & " " & Rng & " " & " " & "غير موجود", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "") End If On Error Resume Next sh2.ShowAllData Application.ScreenUpdating = True On Error GoTo 0 End Sub مع وضع هدا الكود في حدث شيت (الشهر) Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub If Target.Address(False, False) = "C2" And Target.Value <> "" Then Call BFVB End If End Sub mywork 6.xlsm

الدالة int تقرب الى اصغر قيمة للعدد الصحيح 9.5 = 9 اما الاعداد السالبة فتقرب الى العدد الاكبر 9.5- = 10- لذا ان كانت الحقول تحتمل وجود كسور عشرية فان استخدامها لن يعود بنتيجة صحيحة والافضل استخدام val val([text1])+val([text2])

هذه مشاركة فيها تطبيق لتخميني لا تعتمدها إلا إذا كنت متأكدا منها. عندما تتأكد 100% من اختيارك قم بتبديل اختيارك لأفضل إجابة إما للمرفق WM2000_06 أو WM2000_07 WM2000_07.mdb

المزيد في هذا الملف حيث يتم ادراح مقاطع صفحات الطباعة (كل 25 اسم على لائحة منفردة) الكود Option Explicit Sub Give_Me_Printing_Data_Please() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim Data As Worksheet Dim ws2 As Worksheet Set Data = Sheets("data") Set ws2 = Sheets("Archive") Dim m%: m = 1 Dim Arr() Dim final_row With ws2 .Range("a38:j10000").ClearContents .Range("c10:j34").ClearContents End With Dim Capcity%, i%, k%, Max_ro% Dim ro%: ro = 39 Dim first_row%: first_row = 10 Dim lr_data% lr_data = Data.Application.Max(Data.Range("A:A")) Capcity = lr_data \ 25 If lr_data Mod Capcity > 0 Then Capcity = Capcity + 1 For k = 1 To Capcity - 1 ws2.Range("c5:j37").Copy ws2.Range("c" & ro) ro = ro + 33 Next For i = 6 To lr_data + 25 Step 25 ws2.Range("c" & first_row).Resize(25, 5).Value = _ Data.Range("a" & i).Resize(25, 5).Value Max_ro = ws2.Range("c:c"). _ Find(Application.Max(ws2.Range("c:c"))).Row first_row = IIf(i < 30, Max_ro + 10, Max_ro + 9) ReDim Preserve Arr(1 To m) Arr(m) = Max_ro + 3 m = m + 1 Next '=================================== With Sheets("Archive") final_row = ws2.Cells(Rows.Count, "E").End(3).Row Arr(UBound(Arr)) = final_row + 2 .PageSetup.PrintArea = .Range("c5:j" & final_row + 1).Address .ResetAllPageBreaks .VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1 For k = 1 To UBound(Arr) - 1 If k = UBound(Arr) - 1 Then .HPageBreaks.Add Before:=.Cells(Arr(k) + 3, 1) Else .HPageBreaks.Add Before:=.Cells(Arr(k) + 1, 1) End If Next End With '================================ MsgBox "That is All" & Chr(10) & "You have " & Capcity & " Pages To Print" _ & Chr(10) & "Good Luck From Salim" With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With Erase Arr End Sub الملف من حديد Print_ALL_In_one_sheet.xlsm

1-حيث ان البيانات كثيرة جداً فقد تم اختصار الملف الى حوالي 100 اسم للتحقق من عمل الماكرو (يمكن الان تعميم الماكرو على كل الملف) 2-هناك خلايا مدمجة في الملف مما يعيق عمل الماكرو (تم التعدبل على بنية الملف لازالة الخلايا المدمجة) 3-في المرة المقبلة حاول تجنب الخلايا المدمحة واختصار الملف الى أقل عدد ممكن من البيانات 4- تم معالجة الامر في الملف المرفق 5- ارجو ان ينال الاعجاب الكود Option Explicit Sub Give_Me_Data_Please() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim Data As Worksheet Dim ws2 As Worksheet Set Data = Sheets("data") Set ws2 = Sheets("Archive") With ws2 .Range("a38:j10000").ClearContents .Range("c10:j34").ClearContents End With Dim Capcity%, i%, k%, Max_ro% Dim ro%: ro = 39 Dim first_row%: first_row = 10 Dim lr_data% lr_data = Data.Application.Max(Data.Range("A:A")) Capcity = lr_data \ 25 If lr_data Mod Capcity > 0 Then Capcity = Capcity + 1 For k = 1 To Capcity - 1 ws2.Range("c5:j37").Copy ws2.Range("c" & ro) ro = ro + 33 Next For i = 6 To lr_data + 25 Step 25 ws2.Range("c" & first_row).Resize(25, 5).Value = _ Data.Range("a" & i).Resize(25, 5).Value Max_ro = ws2.Range("c:c"). _ Find(Application.Max(ws2.Range("c:c"))).Row first_row = IIf(i < 30, Max_ro + 10, Max_ro + 9) Next With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف ALL_In_one_sheet.xlsm