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

كل دالة لحساب الأعمار لا تعطي هذه النتائج فهي تحتاج إلى مراجعة. علما أن هذه النتائج من دالة تعطي ناتج طرح تاريخ من نفسه يوما واحدا وليس صفرا، ولتكون المقارنة عادلة للدوال التي تعطي صفرا عليهم بطرح يوم من تاريخ البداية. ' DateFm DateTo Period '28/02/2010 01/02/2015 04-11-05 '01/03/2010 01/02/2015 04-11-04 '02/03/2010 01/02/2015 04-11-03 '03/03/2010 01/02/2015 04-11-02 '04/03/2010 01/02/2015 04-11-01 '05/03/2010 01/02/2015 04-11-00 '06/03/2010 01/02/2015 04-10-27 جربوا دوالكم وزودونا بنائجها.

تفضل أستاذ @nssj حسب مافهمت . استعلامان للقيم الحقول المكررة (duplicates(HNO)) و(duplicates(SU_ID)) . TAB3-1.rar

طريقة اخرى مختصرة باستخدام دالة العد الشايب Database1.accdb

نعم أستاذنا @ابوخليل شغال بامتياز - ربما أن لم أنتبه رغم أنني جربته الكود كثيرا الحل كان فقط في إضافة إلى الدالة التي وضعته للتعديل عليها فقط الكود المبين أسفله ولهذا كان النتيجة تأتي خطأ أشركم جميعا أستاذنا الكرام من صميم القلب على التفاعل والاهتمام بموضوعي ولما تقدمونه من مساعدة و إعانة للآخرين @ابوخليل @Foksh @kkhalifa1960 ربي يجازيكم خير الجزاء وجعلها الله في ميزان حسناتكم و ربي يبارك في هذا المنتدى الرائع و في القائمين و المشرفين عليه و كذا في جميع أعضاءه إن شاء الله ' تحويل 30 يومًا إلى 01 شهر If days = 30 Then months = months + 1 days = 0 End If

لتحقيق الهدف على ما اعتقد قم باضافة شرط آخر وهو :- قم باستبدال هذا الجزء بما يلي If Day(startDate) = Day(endDate) + 1 Then days = 0 Elseif days > 30 Then months = months + 1 days = days - 30 End If جرب و وافني بالرد

هذا الحل نموذجي ويحقق المطلوب 100% يجب ان تتأكد انا جربت الكود يعمل على احسن وجه اذا الايام 30 يجعلها صفر ويزيد 1 للشهور واذا كانت اقل يبقيها كما هي واليك التطبيق db1.accdb

Sub TEST1() Dim WordApp As Object, objDoc As Object, Fname As Variant Dim WSdst As Worksheet: Set WSdst = ThisWorkbook.Sheets("word") WSdst.Cells.Clear Fname = Application.GetOpenFilename("Word Documents, *.doc*") If Fname = False Then Exit Sub On Error Resume Next Set WordApp = CreateObject("Word.Application") Set objDoc = WordApp.Documents.Open(Fname) WordApp.Selection.WholeStory WordApp.Selection.Copy WSdst.Range("A1").Select ActiveSheet.Paste With WSdst .Cells.EntireRow.AutoFit: .Columns("A:A").ColumnWidth = 15: '<- قم بتنسيق الورقة بما يناسبك .Columns("A:D").HorizontalAlignment = xlCenter: .Columns("B:E").ColumnWidth = 31 End With objDoc.Close False WordApp.Quit Set WordApp = Nothing Set objDoc = Nothing End Sub في حالة الرغبة باختيار صفحات معينة اليك الكود التالي Sub ImportWordTablesArray() Dim tables() As Variant Dim WordApp As Object, WordDoc As Object Dim arrFile As Variant, Filename As Variant Dim Table As Integer, iCol As Integer Dim iRow As Long, Cpt As Long, Counter As Long Dim WSdst As Worksheet: Set WSdst = ThisWorkbook.Sheets("word") On Error Resume Next arrFile = Application.GetOpenFilename("ملف وورد (*.doc; *.docx),*.doc;*.docx", 2, _ "اظافة الملف", , True) If Not IsArray(arrFile) Then Exit Sub Application.ScreenUpdating = False Set WordApp = CreateObject("Word.Application") WordApp.Visible = False WSdst.Cells.Clear '<- '<-افراغ البيانات السابقة For Each Filename In arrFile Set WordDoc = WordApp.Documents.Open(Filename, ReadOnly:=True) With WordDoc Table = WordDoc.tables.Count If Table = 0 Then MsgBox WordDoc.Name & "لا يحتوي على جداول", vbExclamation, "استيراد" End If tables = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24) '<- '<- ارقام الصفحات For Counter = LBound(tables) To UBound(tables) With .tables(tables(Counter)) For iRow = 1 To .Rows.Count For iCol = 0 To .Columns.Count Cells(Cpt, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text) Next iCol Cpt = Cpt + 1 Next iRow End With Cpt = Cpt + 1 With WSdst .Cells.EntireRow.AutoFit: .Columns("A:b").AutoFit: '<- قم بتنسيق الورقة بما يناسبك .Columns("A:D").HorizontalAlignment = xlCenter: .Columns("c:e").ColumnWidth = 31 End With Next Counter .Close False End With Next Filename WordApp.Quit Set WordDoc = Nothing Set WordApp = Nothing End Sub WORD.rar

اعتذر عن الانقطاع لظروف مرضية ان شاء الله سوف نبدأ فى الاستمرار تباعا بامر الله

Sub Test() Dim lr As Long, r As Range Dim ws As Worksheet: Set ws = Worksheets("واجهة") Dim Wdst As Worksheet: Set Wdst = Worksheets("مبيعات") Const Check = "A13:C13": Set r = ws.Range(Check): Rng = ws.[A3:AA13].Value lr = Wdst.Cells(Rows.Count, 3).End(xlUp).Row + 1 If Application.WorksheetFunction.CountA(r) < r.Count Then MsgBox "برجاء اكمال البيانات", vbExclamation, "كود الترحيل " Exit Sub Else Wdst.Range("A" & lr).Resize(UBound(Rng), UBound(Rng, 2)).Value2 = Rng ws.[A13:AA13] = Empty MsgBox "تم بنجاح", vbInformation, "كود الترحيل " End If End Sub ترحيل1 V1.xlsm

أدخلت تعديل على الدالة ولكن هي تعمل بنفس الأسلوب التعديل أن تعطي القيمة "" في حالة عدم وجود وحدة القياس وتعطي الناتج بالسالب في حالة لم يجد نفس الوحدة. صاحب الموضوع يا أنه تاه أو أنه مل، إن شاء الله يرجع لنا سريعا. Function getBalance(DumpVal) As Variant Dim sht1 As Worksheet, main As Worksheet Dim lrow As Integer, row As Integer Dim unit As String Set sht1 = Sheets("ورقة1") Set main = Sheets("رئيسي ") getBalance = "" With sht1 lrow = .Range("B1").End(xlDown).row unit = Trim(.Cells(lrow, 3)) If unit = "" Then Exit Function getBalance = -.Cells(lrow, 2) End With With main lrow = .Range("B1").End(xlDown).row For row = lrow To 2 Step -1 If .Cells(row, 1) Like "*" & unit Then getBalance = .Cells(row, 2) + getBalance Exit For End If Next row End With Set sht1 = Nothing Set main = Nothing End Function getBalance_07.xlsm

مجهود تشكر عليه استاذ احمد محاولة بطريقة اخرى ربما تتضح الفكرة في انتظار التوضيح اكثر من صاحب الملف =(INDEX('رئيسي '!B:B,MAX(('رئيسي '!$A$2:$A$100="كرتونة صنف "&$A$1)*ROW($A$2:$A$100)*('رئيسي '!$B$2:$B$100<>""))))-(INDEX(B:B,MAX(($C$2:$C$100=$A$1)*ROW($C$2:$C$100)*($B$2:$B$100<>""))))&" "&"علبة" getBalance 6.xlsm

رسوم.xlsx تفضل اخي الكريم