عمل خلاصة بالتواريخ والارقام

[kkfhvvv]

حياكم الله

عندي طلب - ارجو مشكورين الاطلاع عليه وحله

جلب الاسماء والتواريخ والارقام في خانة واحدة

وكما موضح بالملف

جزاكم الله خير

تقرير.xlsx

[abouelhassan]

تفضل طلبك

abouelhassan.xlsm

[kkfhvvv]

السلام عليكم - اشكرك على سرعة الاجابة - وجزاك الله خير

ولكن

مو هذا طلبي - اعزكم الله

طلبي هو جلب ارقام وتواريخ بدون تكرار 

وممكن تعديل على الطلب ليصبح كما بالملف والنتائج المكورة 

 

تقرير.xlsx

تم تعديل فبراير 16 بواسطه kkfhvvv
اضافة طلب اخر جديد

[abouelhassan]

انا نفذت الموجود بالملف المرفق

[kkfhvvv]

السلام عليكم - حياك الله اساتذنا الغالي

الملف في المشاركة الاولى - كان المطلوب جلب الارقام والتواريخ ولكن دون تكرار - وكما كان موضح 

الكود والله مال استاذ فعلا

وكان ليسع صدرك 

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

 

[abouelhassan]

طيب ايه المطلوب تفصيلا فى الملف الذى ارسلته لك اخى الكريم

[kkfhvvv]

السلام عليكم

الملف الذي ارسلته الذي يحتوي على الكود الذي هو من تصميمك

تأتي كل التكرارات التي تخص الارقام والتواريخ

المطلوب هو عدم تكرار الرقم والتاريخ فاذا كان الرقم مثلا ( 55 ) مكرر اكثر من مرة وبنفس التاريخ  - اريد ياتي رقم واحد  وتاريخ واحد

اني التكررارات لا تخدمني 

وارفقت الملف الذي يحتوي على على الكود - ووضحت المطلوب كمثال

abouelhassan123.xlsm

[abouelhassan]

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

[kkfhvvv]

عدم التكرار رقم المطالبة وتاريخها

واذا كان اسم المكتب ( مثلا : رقم المكتب 3 ) يحتوي على ارقام مطالبة وتواريخها متكررة

جلب الارقام والتواريخ بدون تكرار

[abouelhassan]

جرب

Sub ProcessData()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lastRow As Long, i As Long
    Dim officeName As String, dateValue As String, claimNumber As String
    Dim uniqueOffices As New Collection
    Dim officeDates As New Dictionary
    Dim officeClaims As New Dictionary
    
    ' Set references to the worksheets
    Set ws1 = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to the actual name of your worksheet
    Set ws2 = ThisWorkbook.Sheets("Sheet2") ' Change "Sheet2" to the actual name of your worksheet
    
    ' Find the last row in worksheet 1
    lastRow = ws1.Cells(ws1.Rows.Count, "O").End(xlUp).Row
    
    ' Loop through the data in worksheet 1
    For i = 1 To lastRow
        ' Get the office name
        officeName = ws1.Cells(i, "O").Value
        ' Add the office name to the uniqueOffices collection
        On Error Resume Next
        uniqueOffices.Add officeName, CStr(officeName)
        On Error GoTo 0
        ' Get the date value
        dateValue = CStr(ws1.Cells(i, "P").Value)
        ' Get the claim number
        claimNumber = CStr(ws1.Cells(i, "Q").Value)
        ' Add the date and claim number to the dictionaries if they don't already exist
        If Not officeDates.Exists(officeName) Then
            officeDates.Add officeName, dateValue
            officeClaims.Add officeName, claimNumber
        ElseIf InStr(1, officeDates(officeName), dateValue) = 0 Then
            officeDates(officeName) = officeDates(officeName) & " + " & dateValue
        ElseIf InStr(1, officeClaims(officeName), claimNumber) = 0 Then
            officeClaims(officeName) = officeClaims(officeName) & " + " & claimNumber
        End If
    Next i
    
    ' Write the unique office names to worksheet 2
    Dim office As Variant
    Dim rowIndex As Long: rowIndex = 1
    For Each office In uniqueOffices
        ws2.Cells(rowIndex, 1).Value = office
        ' Write the dates for each office
        ws2.Cells(rowIndex, 2).Value = officeDates(office)
        ' Write the claim numbers for each office
        ws2.Cells(rowIndex, 3).Value = officeClaims(office)
        rowIndex = rowIndex + 1
    Next office
    
    MsgBox "Process complete."
    
End Sub

يرجى تغيير اسمي الورقتين "Sheet1" و "Sheet2" إلى الأسماء الفعلية للورقتين الخاصتين بك.

[kkfhvvv]

السلام عليكم

ظهرت لي هذه الرسالة

[abouelhassan]

السطر الذي تشير إليه يقوم ب لاستخدام الكائن Dictionary. يمكنك فعل ذلك من خلال اتباع الخطوات التالية:

1. في محرر VBA، انتقل إلى القائمة "Tools" ثم "References" (أو "Tools" ثم "References" في Excel 2010).
2. ابحث عن "Microsoft Scripting Runtime" في القائمة.
3. حدد المربع بجانب "Microsoft Scripting Runtime".
4. انقر فوق "OK" لحفظ التغييرات.

تم تعديل فبراير 18 بواسطه abouelhassan

[kkfhvvv]

تمام 100 %

عاشت الايادي

وزادتك الله 

تسلم