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

عندي هذا النموذج الرائع منذ سنوات واستخدمه في كل برامجي هو للامانة ليس من تصميمي اتوقع صممه الأخ الحبيب @ابو جودي اقدمه لكم هديه فهناك من يحتاجه بحث حسب تاريخ.accdb

اختلط علي الأمر هههههههه بسيطة دي يا دكتور .. احنا نحجز متغير من نوع Date وليكن اسمه التاريخ السابق ( PreviousDate ) ، ونحدد قيمته بناقص يوم للتاريخ الذي في مربع النص Text15 ، ثم نحدد قيمة مربع النص Text17 بتغيير بسيط ، ليصبح الكود كالآتي :- Dim PreviousDate As Date PreviousDate = DateAdd("d", -1, Me.Text15.Value) Me.Text17.Value = Nz(DLookup("rased", "T1", "mastedate = #" & Format(PreviousDate, "mm/dd/yyyy") & "#"), 0)

لما شرحته في طلبك ، ارفق ملف ليتم العمل عليه 😊

أهلاً بك معنا في منتدانا الكبير ، وأتمنى أن تجد الفائدة التي ترجوها . وما ذكرته لك حتى لا يتعرض موضوعك للإغلاق أخي @صالح الصالحي

حاضر سأقوم بإعادة ارسالة مع تعديل ماذكرت واعذرني فأنا قليل خبرة في المنتدى والاكسس

ارجو أخي الكريم @صالح الصالحي ان تقوم بالغاء افضل إجابة ، واستخدامها لحين ان تجد الإجابة الصحيحة أياً كان مقدمها ، هذا أولاً ثانياً ، التزاماً بقواعد المنتدى ادراج بعض البيانات التي ترغب بانتاج البحث والتقارير عنها ، وليس ارفاق ملف فارغ وكأنك تريد ممن يقدم المساعدة أن يملأه ثالثاً ، للوصول لحلول لمشكلتك :- لا تستخدم أسماء عربية في مسميات الحقول . لا تستعمل المسافات بين الأسماء . لا تستعمل اسماء حقول محجوزة للبرنامج مثل ( Name,Date,To,From ..... إلخ ) لا تستعمل رموز ( #، @،$،& .... إلخ ) في مسميات الحقول . لا تستعمل الأرقام في أسماء حقول الجداول أو تبدأ بها . قواعد المشاركة بمنتدي أوفيسنا

السلام عليكم اخونا الكبير شايب يعتقد ان طريقة جعفر للعمل على النواتين طريقة شاملة ولكن في مثل هذه الحالة التي واجهت الاستاذ سلوم بعد اضافة Ptrsafe فقط يكفي ان نقوم بتغير اي متغير رقمي من long الى LongLong او الى LongPtr وسوف يعمل البرنامج ويختصر عدة اسطر من الكود اخير LongPtr ليس نوع بيانات حقيقي وانما يتوافق مع الاصدرين 32 و 64 بحيث يتحول الى long مع 32 و longlong مع 64 ايضاح اخير يمكن تقيد فتح النموذج الاخير بحيث لا يمكن فتحه الا من خلال زر الامر بعد كتابة الرمز الصحيح ولكن نكتفي بهذه المشاركة اخونا الشايب رقم سري.accdb

جزاك الله خير على الهدية أخونا الفاضل @عبد اللطيف سلوم ، ولمشاركتك فكرة أستاذنا @ابو جودي ( رغم غيابه عنا في الفترة الأخيرة ) . إلا أني دائماً أتوجه إلى أن تكون بداية الأسبوع عندي يوم السبت وليس الإفتراضي حسب الكمبيوتر يوم الأحد ، فهذا تعديل لا يلمس شيء في هديتك سوى أنه يجعل احتساب الأسبوع يبدأ من يوم السبت لا الأحد . Private Sub salloum_AfterUpdate() Me.x1 = Me.salloum.Column(1) Select Case Me.salloum.Column(0) Case "1" Me.n1 = DateSerial(Year(Date), 1, 1) Me.n2 = DateSerial(Year(Date), 12, 31) Case "2" Me.n1 = DateSerial(Year(Date), Month(Date), 1) Me.n2 = DateSerial(Year(Date), Month(Date) + 1, 0) Case "3" Me.n1 = DateAdd("d", -Weekday(Date, vbSaturday) + 1, Date) Me.n2 = DateAdd("d", 6, Me.n1) Case "4" Me.n1 = DateSerial(Year(Date) - 1, 1, 1) Me.n2 = DateSerial(Year(Date) - 1, 12, 31) Case "5" Me.n1 = DateSerial(Year(Date), Month(Date) - 1, 1) Me.n2 = DateSerial(Year(Date) - 1, 12, 31) Case "6" Me.n1 = DateAdd("d", -Weekday(Date, vbSaturday) + 1, Date) - 7 Me.n2 = DateAdd("d", 6, Me.n1) Case "7" Me.n1 = Null Me.n2 = Null End Select End Sub

Foksh كتر اف خيرك ...تمام بالظيط هوا ده اللى انا عايزه ..متشكر جدااااااا kkhalifa1960 اخى الكريم ...متشكر جدا لاهنمامك بس الحمد لله لقيت الحل ..وكتر الف خير

ادن اخي حاول التركيز معي سنشتغل على شيت الفواتير لترحيل البيانات اليه مع مراعات عدم تكرار الفواتير في حالة وجودها مسبقا اعتمادا على رقم الاسبوع الدي سيتم اظافته تلقائيا استنادا الى اخر تاريخ للفواتير المرحلة ويوم بداية الاسبوع الافتراضي بالنسبة لك هو يوم (الجمعة) مع اخد في عين الاعتبار تنسيق وشكل البيانات بعد كل ترحيل المطلوب مسبقا الاكواد طويلة نوعا ما بسبب التنسيقات المطلوبة لاكنها سريعة في التنفيد 😉 كود الترحيل Sub Copy_data() Dim StDate$, EnDate$, iCnt&, fRow&, Invoice$ Dim rngMain As Range, rngCount, LR&, x& Dim arrMain As Variant, arrCount() As Variant, sht As Worksheet Dim Cpt As Range: Dim FndRng As Range: Dim MyRng As Range: Dim c As Range Dim week As Date: Dim i As Integer: Dim Clé As Range: Dim xDate As Range Dim d As Integer: Dim FindWeek As Range: Dim OneRng As Range: Dim n As Range Dim desWS As Worksheet: Set desWS = ActiveSheet Dim srcWS As Worksheet: Set srcWS = Sheets("فواتير الاسبوع") Dim WS As Worksheet: Set WS = sheet1 Set Clé = desWS.[BU331]: Set MyRng = desWS.[BW330:CK372] StDate = desWS.[CA328]: EnDate = desWS.[CE328] week = desWS.[DC330].Value d = 15 ' اليوم الافتراضي لبداية الأسبوع (الجمعة) st = Application.WeekNum(week, d) On Error Resume Next Application.ScreenUpdating = False If Len(desWS.[CA328].Value) = 0 Then Exit Sub Set FindWeek = srcWS.Rows(3).Find(what:=st, LookIn:=xlValues, _ LookAt:=xlWhole) If Not FindWeek Is Nothing Then If MsgBox(" تم ترحيل فواتير الأسبوع" & " " & st & " :" & "مسبقا" & Chr(10) & Chr(10) _ & " معاينة الفاتورة" & "؟", vbYesNo, "تم إلغاء الإجراء") = vbYes Then Dim cel As Range Invoice = st.Value For Each c In srcWS.Rows(3) If c.Value = Invoice Then Set cel = srcWS.Range(FindWeek.Address) Application.GoTo Reference:=cel ActiveWindow.ScrollColumn = cel.Column - 13: ActiveWindow.ScrollRow = cel.Row - 2 Exit Sub Next End If Exit Sub Else With Application .ScreenUpdating = False .DisplayAlerts = False WS.Cells.Clear For i = StDate To EnDate: Clé.Value = i MyRng.Copy If WorksheetFunction.CountA(WS.Cells) = 0 Then LR = WS.Cells(Rows.Count, "j").End(xlUp).Row + 1 Else LR = WS.Cells(Rows.Count, "j").End(xlUp).Row + 3 End If With WS.Range("A" & LR) .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats Application.CutCopyMode = False End With Next i fRow = WS.Range("A:O").Find("*", SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row WS.ResetAllPageBreaks: WS.PageSetup.Zoom = False WS.PageSetup.PrintArea = "A:O": WS.PageSetup.Orientation = xlLandscape For i = 1 To fRow Step 45 j = j + 1 WS.HPageBreaks.Add WS.Range("A" & i) Next i WS.PageSetup.FitToPagesWide = 1: WS.PageSetup.FitToPagesTall = j Set sht = Sheets.Add(After:=Sheets(Sheets.Count)) WS.Range("A1:O" & fRow + 1).Copy With sht.Range("b" & Rows.Count).End(xlUp)(2) .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats: .PasteSpecial xlPasteColumnWidths Application.CutCopyMode = False End With Irow = sht.Range("A:P").Find("*", SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row + 1 Set rngMain = sht.Range("A2:P" & Irow) Set rngCount = sht.[A3]: arrMain = rngMain.Value ReDim arrCount(1 To UBound(arrMain, 1), 1 To 1) For x = 1 To UBound(arrMain) If arrMain(x, 3) = "حامض" Then iCnt = iCnt + 1 arrCount(x - 5, 1) = iCnt End If Next x With rngCount.Resize(UBound(arrMain), 1) .Value = arrCount: .Font.Color = RGB(255, 0, 0): .Font.Bold = True: .Font.Size = 20 End With If WorksheetFunction.CountA(srcWS.Cells) = 0 Then Set OneRng = srcWS.Rows("1:4") For Each c In OneRng c.HorizontalAlignment = xlGeneral: c.VerticalAlignment = xlCenter: c.HorizontalAlignment = xlCenter c.RowHeight = 22: c.Font.Bold = True:: c.Font.Size = 14 Next c lCol = srcWS.Cells(10, srcWS.Columns.Count).End(xlToLeft).Column ' + 1 Else lCol = srcWS.Cells(10, srcWS.Columns.Count).End(xlToLeft).Column + 3 End If Dim Col_Widths As Range Set Col_Widths = Union(srcWS.Cells(lCol + 3), srcWS.Cells(lCol + 5), srcWS.Cells(5, lCol + 9)) Set Col_Border = Union(srcWS.Cells(lCol + 3), srcWS.Cells(lCol + 5), srcWS.Cells(5, lCol + 9), srcWS.Cells(1, lCol + 4)) rngMain.Copy With srcWS.Cells(5, lCol) .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats: .PasteSpecial xlPasteColumnWidths Application.CutCopyMode = False Col_Widths.ColumnWidth = 18 j = Array(StDate, "", "", "", EnDate) With srcWS.Cells(1, lCol + 4).Offset(1).Resize(, 5) .Value = j: .Interior.Color = vbYellow: .Font.Color = RGB(255, 0, 0) .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium, Color:=RGB(0, 0, 0) With srcWS.Cells(3, lCol + 12) .Value = "الأسبوع رقم :": .Font.Color = RGB(255, 0, 0): .Interior.Color = vbYellow .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium, Color:=RGB(0, 0, 0) With srcWS.Cells(3, lCol + 13) .Value = st: .Font.Color = RGB(255, 0, 0): .Interior.Color = vbYellow .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium, Color:=RGB(0, 0, 0) End With End With End With End With srcWS.Activate: ActiveWindow.ScrollRow = 1: ActiveWindow.ScrollColumn = 1: [B6].Select: ActiveWindow.Zoom = 95 a = Array("فواتير الأسبوع من", " ", CDate(desWS.[CV330]), " ", "إلى", " ", CDate(desWS.[DC330])) With srcWS.Cells(2, lCol + 3).Offset(1).Resize(, 7) .Value = a: .Interior.Color = RGB(255, 255, 0) .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium, Color:=RGB(0, 0, 0) End With For Each xDate In srcWS.Range("D3", srcWS.Cells(3, Columns.Count).End(xlToLeft)) If IsDate(xDate.Value) Then xDate.NumberFormat = "yyyy-mm-dd" Next xDate sht.Delete MsgBox " تم ترحيل فواتير الأسبوع رقم :" & " " & st & " " & "بنجاح", vbInformation, "معلومات" desWS.Activate On Error GoTo 0 .DisplayAlerts = True .ScreenUpdating = True End With End If End Sub اما بالنسبة لكود حفظ الفواتير بصيغة PDF تم فصله وتعديله لتتمكن من حفظ او طباعة اي فواتير مرحلة مسبقا بعد استدعائها بشرط رقم الاسبوع بالشكل المطلوب مسبقا (كل فاتورة في ورقة مستقلة) Sub Choose_invoice_Print() Dim rng As Range, c As Range, Invoice As Range Dim Cpt&, Path As String, sFile As String Dim desWS As Worksheet: Set desWS = ActiveSheet Dim srcWS As Worksheet: Set srcWS = Sheets("فواتير الاسبوع"): Set WS = sheet1 On Error Resume Next If WorksheetFunction.CountA(srcWS.Cells) = 0 Then: MsgBox "لا توجد بيانات للحفظ", vbInformation, "تم إلغاء الإجراء": Exit Sub Choose_invoice = InputBox(" المرجوا ادخال رقم الأسبوع " & "؟", " : حفظ وطباعة الفواتير الأسبوعية") If Choose_invoice = "" Then: Exit Sub FolderName = "Raed": Path = ThisWorkbook.Path & "\" & FolderName Set FindWeek = srcWS.Rows(3).Find(what:=Choose_invoice, LookIn:=xlValues, _ LookAt:=xlWhole) If Not FindWeek Is Nothing Then sFile = "الفواتير من" & " " & Format(FindWeek.Offset(0, -8).Text, "dd-mm-yyyy") _ & " " & "إلى" & " " & Format(FindWeek.Offset(0, -4).Text, "dd-mm-yyyy") Msg = MsgBox("؟" & " " & "PDF " & ":" & " حفظ فواتير الأسبوع" & " / " & FindWeek & " بصيغة", vbYesNo, sFile) If Msg <> vbYes Then Exit Sub Invoice = Choose_invoice.Value Application.ScreenUpdating = False For Each c In srcWS.Rows(3) If c.Value = Invoice Then Application.GoTo Reference:=srcWS.Range(FindWeek.Address) WS.Visible = xlSheetVisible: WS.Cells.Clear Cpt = ActiveCell.Column - 3 Irow = srcWS.Cells(srcWS.Rows.Count, Cpt).End(xlUp).Row Set rng = Range(ActiveCell.Offset(3, -12), ActiveCell.Offset(Irow - 2, 2)) rng.Copy With WS.Range("A" & Rows.Count).End(xlUp)(2) .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats: .PasteSpecial xlPasteColumnWidths Application.CutCopyMode = False End With Next f = WS.Range("A:O").Find("*", SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row WS.ResetAllPageBreaks: WS.PageSetup.Zoom = False WS.PageSetup.PrintArea = "A:O": WS.PageSetup.Orientation = xlLandscape For i = 1 To f Step 45 j = j + 1 WS.HPageBreaks.Add WS.Range("A" & i) Next i WS.PageSetup.FitToPagesWide = 1: WS.PageSetup.FitToPagesTall = j If Dir(Path, vbDirectory) = "" Then MkDir Path nf = Dir(Path & "\" & sFile & "*") n = 0 Do While nf <> "" n = n + 1 nf = Dir Loop WS.ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=Path & "\" & sFile & " (" & n + 1 & ")" & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False ' تفعيل الطباعة 'WS.PrintOut WS.Visible = xlSheetVeryHidden Application.ScreenUpdating = True Else MsgBox "رقم الأسبوع غير موجود على قاعدة البيانات", vbExclamation, "تم إلغاء الإجراء" End If On Error GoTo 0 desWS.Activate End Sub Book معدل 2.xls

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

صديقي الدكتور @الحلبي ، أعلم جيداً انك قد توجهت للدالة Dlookup وأنك لم تحصل ما تطلبه والسبب هو باعتقادي أنه بالتاريخ المطلوب الذي حددته سيقرأ اكسيس التاريخ على انه تنسيق dd/mm/yyyy ولكنه في الواقع بهذا التنسيق mm/dd/yyyy ، لذا تفضل بتجربة هذا السطر في حدث بعد التحديث لمربع نص التاريخ Text15 :- Me.Text17.Value = Nz(DLookup("rased", "T1", "mastedate = #" & Format(Me.Text15.Value, "mm/dd/yyyy") & "#"), 0) الرصيد.accdb جرب وأخبرني بالنتيجة

استاذي الخلوق lionheart لا يسع حرفي ان يوفي من شكر لسرعة الاستجابة وعبقرية الحل اسأل الله لك الصحة والعافية وعذرا لو سمح وقت حضرتك اضافة عمود اخر بعنوان تاريخ الانتهاء دمت وادامك الله بكل الخير تقديري

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

السلام عليكم ورحمة الله وبركاته تفضل أخي الكريم الملف المعدل يعمل علي النواتين 32x and 64x بالتوفيق A_رقم سري.zip

فعلا الكود يعمل على نظام 32 بكفاءة ، لكن على نظام 64 فلا يعمل عند إضافة الجزء Ptrsafe كما حاول الأستاذ @عبد اللطيف سلوم 😉 . لربما موضوع أستاذنا جعفر واسع النطاق وأساس الإجابة كما تفضل استاذ خليفة .

مشاركة مع الاساتذة الكرام تفضل أستاذ @TAMER AGOOR محاولتي حسب مافهمت . ووافني بالرد . Private Sub Ch_Click() 'On Error Resume Next If Me.Ch = False Then Me.CmdPrint.Caption = "Print rpt_Emp" Me.CmdPrint.BackColor = vbRed Else Me.CmdPrint.Caption = "Print rpt_Items" Me.CmdPrint.BackColor = vbBlue End If End Sub Private Sub CmdPrint_Click() On Error Resume Next If Me.Ch = False Then Me.CmdPrint.Caption = "Print rpt_Emp" Me.CmdPrint.BackColor = vbRed DoCmd.OpenReport "rpt_Emp", acViewNormal Else Me.CmdPrint.Caption = "Print rpt_Items" Me.CmdPrint.BackColor = vbBlue DoCmd.OpenReport "rpt_Items", acViewNormal End If End Sub

استاذ @عبد اللطيف سلوم المرفق يعمل بكفاءة كما بالشرح . ووضحت لك مكان جدول النظام الذي به الباسوورد .

وعليكم السلام ورحمه الله وبركاته تفضل اخي لعله طلبك ماكرو قبل الطباعة.xlsm

Try Sub Test() Dim ws As Worksheet, m As Long, i As Long, ii As Long Application.ScreenUpdating = False Set ws = ActiveSheet: m = 2 With ws .Columns("K:M").Clear .Columns("M").ColumnWidth = 11 With .Range("K1").Resize(, 3) .Value = Array("Group", "Number", "Work Date") .Interior.Color = RGB(146, 205, 220) .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter End With For i = 2 To 6 If .Cells(i, 2).Value < .Cells(i, 3).Value And IsNumeric(.Cells(i, 2).Value) And IsNumeric(.Cells(i, 2).Value) Then For ii = .Cells(i, 2).Value To .Cells(i, 3).Value .Cells(m, "K").Resize(, 3).Value = Array(.Cells(i, 1).Value, ii, .Cells(i, 4).Value) m = m + 1 Next ii End If Next i End With Application.ScreenUpdating = True End Sub

جرب هذا التعديل أخي الكريم ، بعد تجربته عندي طبعاً أعتقد أنه مطلبك قاعده بيانات للتجارب - Copy - Copy.mdb