سحب بيانات من موقع للجدول او استعلام

[أبوبسمله]

السلام عليكم ورحمه الله وبركاته

@صالح حمادي وجميع اخوانى من لديهم خبره فهذا الموضوع وجزاكم الله خيرا

اخوانى واساتذتى الافاضل لدى ملف اكسيل بيسحب بيانات من الموقع وشغال تمام ولكن حاولت ظبطه على الاكسس ولم استطع

سحب البيانات بناء على حقل SupplierCode

مرفق ملف الاكسل والاكسس

وده الموديول الموجود فى الاكسيل

'https://www.brcdirectory.com/InternalSite//Site.aspx?BrcSiteCode=1845026

Sub Get_Grade_Expiry_Date()
    Dim dic As Object, sResult As String, sCode As String, r As Long
    
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    
    For r = 2 To 10 'Cells(Rows.Count, 4).End(xlUp).Row
        sCode = CStr(Cells(r, 4).Value)
        If sCode <> "" Then
            If Not dic.Exists(sCode) Then
            sResult = GetGradeExpiryDate(CStr(sCode))
            Cells(r, 6).Value = Trim(Split(sResult, "|")(0))
            Cells(r, 7).Value = CDate(Trim(Split(sResult, "|")(1)))
            dic(sCode) = Array(Cells(r, 6).Value, Cells(r, 7).Value)
            Else
            Cells(r, 6).Value = dic(sCode)(0)
            Cells(r, 7).Value = dic(sCode)(1)
            'Stop
            End If
        End If
    Next r
End Sub

Function GetGradeExpiryDate(ByVal sCode As String)
    Dim http As MSXML2.XMLHTTP60, html As MSHTML.HTMLDocument, sURL As String, sGrade As String, sExpiry As String
    
    sURL = "https://www.brcdirectory.com/InternalSite//Site.aspx?BrcSiteCode=" & sCode
    Set http = New MSXML2.XMLHTTP60
    Set html = New MSHTML.HTMLDocument

    With http
        .Open "Get", sURL, False
        .setRequestHeader "User-Agent", "Mozilla/5.0"
        .send
        html.body.innerHTML = .responseText
        sGrade = Split(html.querySelector("#ctl00_ContentPlaceHolder1_FormView1_GridView1_ctl02_lb_Grade").innerText, "Grade : ")(1)
        sExpiry = Split(html.querySelector("#ctl00_ContentPlaceHolder1_FormView1_GridView1_ctl02_lb_ExpiryDate").innerText, "Expiry Date : ")(1)
        GetGradeExpiryDate = sGrade & "|" & sExpiry
    End With
End Function

 

Get-Grade-Expiry-Date.xlsm Suppliers-Copy-1.accdb

[أبوبسمله]

الحمدلله تم ضبط الكود بنسبه كبيره بفضل الله سبحانه وتعالى بمساعده اخ عزيز عليا

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

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

بالتوفيق اخوانى

[صالح حمادي]

السلام عليكم

من المفترض أنني وضعت درس التعامل الأنترنت باستخدام FTP

و لكن بعض الظروف منعتني من ذلك

إن كنت مستعجلا فسوف أقوم بالتعديل على ملفك

و إن كنت غير ذلك فسوف أضع الدرس غدا بإذن الله

[أبوبسمله]

1 دقيقه مضت, صالح حمادي said:

السلام عليكم

من المفترض أنني وضعت درس التعامل الأنترنت باستخدام FTP

و لكن بعض الظروف منعتني من ذلك

إن كنت مستعجلا فسوف أقوم بالتعديل على ملفك

و إن كنت غير ذلك فسوف أضع الدرس غدا بإذن الله

جزاك الله خيرا اخى واستاذى صالح ووفقكم الله لما يحبه ويرضاه واعانكم الله على ما يشغلكم

ياريت لو عدلت لى الملف وفى انتظار الشرح وتقبل الله منكم صالح الاعمال

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

[الحلبي]

منور استاذنا / @أحمد الفلاحجى

اضم صوتى لكم وبانتظار استاذنا / @صالح حمادي

وانتهز الفرصة لاقول لكم كل عام وانتم بخير وتقبل الله صيامكم وقيامكم

[أبوبسمله]

1 دقيقه مضت, حلبي said:

منور استاذنا / @أحمد الفلاحجى

اضم صوتى لكم وبانتظار استاذنا / @صالح حمادي

وانتهز الفرصة لاقول لكم كل عام وانتم بخير وتقبل الله صيامكم وقيامكم

ده نورك اخى محمد @حلبي وانت طيب وتقبل الله منكم الصيام والقيام وصالح الاعمال

بارك الله فيك وجزاك الله كل خير

[صالح حمادي]

السلام عليكم

أولا: أخي أحمد لم تضع مثالا لأقوم بالتعديل عليه أنت وضعت جدولا فقط

لقد قمت بإضافة حقل لهذا الجدول اسمه value_web سوف توضع فيه القيمة المستوردة من الويب

و أضفت نموذج به نموذج فرعي 

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

 

 

Suppliers-Copy-1.rar

[أبوبسمله]

1 ساعه مضت, صالح حمادي said:

السلام عليكم

أولا: أخي أحمد لم تضع مثالا لأقوم بالتعديل عليه أنت وضعت جدولا فقط

لقد قمت بإضافة حقل لهذا الجدول اسمه value_web سوف توضع فيه القيمة المستوردة من الويب

و أضفت نموذج به نموذج فرعي 

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

Suppliers-Copy-1.rar 60.67 kB · 1 تنزيلات

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

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

وننتظر الدرس ايضا

الكود يجلب من الموقع قيمتين Grade و Expiry ووضعهم بالحقول بناء على  SupplierCode

جزاك الله خيرا اخى واستاذى @صالح حمادي

Sub Get_BRCDirectory_Data()
    Dim sCode, rs As DAO.Recordset, dic As Object, sResult As String, i As Long
 
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1

    Set rs = CurrentDb.OpenRecordset("Approved")
    If Not (rs.BOF And rs.EOF) Then
        rs.MoveFirst
    
        Do
            sCode = rs.fields("SupplierCode").Value
            
            If sCode <> "" Then
                If Not dic.Exists(sCode) Then
                    sResult = GetGradeExpiryDate(CStr(sCode))
        
                    rs.Edit
                    rs.fields("Grade").Value = Trim(Split(sResult, "|")(0))
                    rs.fields("Expiry").Value = Split(sResult, "|")(1)
                    rs.UPDATE
                    dic(sCode) = Array(rs.fields("Grade").Value, rs.fields("Expiry").Value)
                Else
                    rs.Edit
                    rs.fields("Grade").Value = dic(sCode)(0)
                    rs.fields("Expiry").Value = dic(sCode)(1)
                    rs.UPDATE
                End If
            End If
    
            rs.MoveNext
        Loop Until rs.EOF
    End If
 
    MsgBox "Done", 64
End Sub

 

مرفق المثال

SupplierCode-V1.0.accdb