طلب مساعدة

[Yousefessam]

الملف المرفق يحتوى على بيانات فى جدول

والمطلوب قراعة البيانات من الجدول ووضعها كما فى العمود L 

ملحوظة / الجدول عينة فقط 

GRANITE.xlsx

[محي الدين ابو البشر]

وعليكم السلام والرحمة

ربما

Sub test()
Dim a, w, x, k
Dim i&, ii&
    a = Cells(1).CurrentRegion
    With CreateObject("scripting.dictionary")
        For i = 5 To UBound(a)
            If Not .exists(a(i, 9)) Then
                .Add a(i, 9), Array(a(i, 9), a(i, 2), a(i, 3) & "\" & a(i, 4), "SP" & a(i, 5) & " PORT " & Format(a(i, 6), "0#"), "TB Number " & Format(a(i, 7), "0#"))
            Else
                w = .Item(a(i, 9))
                x = Split(w(3), "-")
                If UBound(x) > 0 Then
               w(3) = x(0) & "- " & Format(a(i, 6), "0#")
                .Item(a(i, 9)) = w
                Else
                x(UBound(x)) = x(UBound(x)) & " -" & Format(a(i, 6), "0#")
                w(3) = Join(x)
                .Item(a(i, 9)) = w
            End If: End If
        Next
       For Each k In .keys
       Cells(5 + ii, 13).Resize(5) = Application.Transpose(.Item(k))
       ii = ii + 6
       Next
    End With
End Sub

 

[Yousefessam]

شكرا اخى

 هل ممكن تطبيقه على الملف المرسل سابقا واعادة ارسال الملف

شكرا استاذ محى الدين - يعمل بامتياز ولكن لى تعديل بسي' جدا لو امكن , فضل كرمك 

تم اضافة عمود يحتوى على ODB  و TB  فمحتاج يقرا اللى مكتوب فى العمود ده  ويضعا مكان ال Tb Number 

مثل الملف المرفق 

كما احتاج يكون التنسيق كم بالملف المرفق

شكرا لمجهودك وتعبك - جعله الله فى ميزان حسناتك

 

GRANITE.xlsx

[محي الدين ابو البشر]

تفضل أخي الكريم

Sub test()
Dim a, w, x, k
Dim i&, ii&
    a = Cells(1).CurrentRegion
    With CreateObject("scripting.dictionary")
        For i = 5 To UBound(a)
            If Not .exists(a(i, 9)) Then
                .Add a(i, 9), Array(a(i, 9), a(i, 2), a(i, 3) & "\" & a(i, 4), "SP" & a(i, 5) & " PORT " & Format(a(i, 6), "0#"), a(i, 10) & " NO -  " & Format(a(i, 7), "0#"))
            Else
                w = .Item(a(i, 9))
                x = Split(w(3), "-")
                If UBound(x) > 0 Then
               w(3) = x(0) & "- " & Format(a(i, 6), "0#")
                .Item(a(i, 9)) = w
                Else
                x(UBound(x)) = x(UBound(x)) & " -" & Format(a(i, 6), "0#")
                w(3) = Join(x)
                .Item(a(i, 9)) = w
            End If: End If
        Next
       For Each k In .keys
       Cells(5 + ii, 14).Resize(5) = Application.Transpose(.Item(k))
       ii = ii + 6
       Next
    End With
End Sub

 

[Yousefessam]

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

بس كرما بعد اذنك - لاحظت ان لو رقم ال tb  ثابت مع عدد 2 سبلتر - المعادلة بتقرا البورت  المقابل من سبلتر  1  وبتنهى بالبورت المقابل  فى سبلتر 2 دون تغيير السبلتر

مرفق الملف - ارجوا تعديل المعادلات لتتناسب مع الايضاح الملون بالملف

GRANITE-Macro.xlsm

[Yousefessam]

دعمك الكريم استاذ محى الدين

مع كل الشكروالتقدير لك

[Yousefessam]

دعمكم الكريم

[Yousefessam]

دعمكم الكريم