طلب كود ماكرو لبحث و إضافة قيم لعمود

[فـهـد]

السلام عليكم

لدي ملف اكسل اقوم بسحبه من موقع حكومي اسبوعيا ، فيه بيانات كثيرة عن مخالفات السيارات ، اود وضع  زرين ماكرو  لعمل الآتي  :

1- الماكرو الأول اسمه كتابة اسم السيارة :

 اود عن الضغط عليه يقوم بكتابة في العمود i  إسم السيارة بما يقابله من رقم اللوحة في العمود  J

   قمت باضافة  شيت آخر باسم Plate_No يحتوي على ارقام اللوحات و اسماء السيارات  لعمل بحث منها و كتابة اسم السيارة في الشيت Sheet1 (في العمود i )

2- الماكرو الثاني   لتحويل عمود التاريخ الهجري (العمود C ) الى تاريخ ميلادي ؟

3- عن طريق ماكرو جديد   هل بالإمكان تنسيق الوقت (في العمود E ) ، لأنه مكتوب بنظام 24 ساعة (لكن بدون فواصل التي بين الدقائق و الساعات)  و تحويل التنسيق الخلايا للوقت   ؟

   مع الشكر الجزيل  مسبقا لجهودكم ..

الملف مرفق

export - Copy.xls

[ابراهيم الحداد]

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

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

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

Sub CarsNames()
Dim ws As Worksheet, Sh As Worksheet
Dim LR As Long, i As Long
Dim Car As String, CarNum As String
Dim WF As Variant
Set ws = Sheets("Sheet1")
Set Sh = Sheets("Plate_No")
Set WF = WorksheetFunction
LR = ws.Range("A" & Rows.Count).End(xlUp).Row
i = 6
Do While i <= LR
CarNum = ws.Range("J" & i).Value
Car = WF.Index(Sh.Range("A2:B" & Sh.Range("B" & Rows.Count).End(3).Row), _
WF.Match(CarNum, Sh.Range("B2:B" & Sh.Range("B" & Rows.Count).End(3).Row), 0), 1)
ws.Range("I" & i) = Car
i = i + 1
Loop
End Sub

 

[ابو تيم]

اخي الفاضل 

بدون الحاجة الى ماكرو

ممكن انك تلصق الداتا الجديدة في شيت ثاني

وتطبق المعادلات في العمودين D و J

تفضل اخي 

إضافة قيم لعمود.xlsm

[أحمد يوسف]

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

Private Function dateGregorian(sDate As String) As String
    Dim vVal As Variant
    Dim dtHijiri As Date

    VBA.Calendar = vbCalHijri
    If sDate <> vbNullString Then
        On Error GoTo XIT
        dtHijiri = DateValue(sDate) + 1
        VBA.Calendar = vbCalGreg
        dateGregorian = dtHijiri
    End If
    Exit Function
XIT:
    dateGregorian = vbNullString
End Function

export 1.xlsm

[فـهـد]

أشكرك جزيل الشكر أخي  @أحمد يوسف     

تمت التجربة بنجاح 

و أشكركم جميعا مرة أخرى :

@ابراهيم الحداد   ، @ابو تيم

تم تجربة الملفات و كلها ناجحة  

دعواتي لكم بالخير و الصحة و العافية لكم و لمن تحبون ..