طلب مساعدة من ذوي الخبرة، لمايكرو webquery يحتاج تصحيح وتعديل حسب الاحتياج

[H_BioMed]

بسم الله والصلاة والسلام على رسول الله سيدنا محمد وعلى آله وصحبة أجمعين

 

اخواني الكرام، شكراً لكم اولاً على كل ماقدمتهم بصفحات هذا المنتدى فلقد استفدت منه كثيراً لأصل الى هذه النتيجه لكن قل خبرتي حيث ان هذا اول تعامل لي مع لغة VB تصعب على تكملة الموضوع، لذلك احتاج المساعدة منكم في تكملة هذا الملف حتى يخرج بالمعطيات التي تخدمنا بإذن الله

 

 

الملف بالمرفقات والتوضيح كالتالي 

 

الملف يحتوي على ورقة عمل بأسم ( sheet1 )  في العامو (A) يوجد روابط صفحات انترنت عددها 164 بمعنى ان الرينج ( A1:A164) 

 

قمت بعمل مايكرو يستدعى كل خلية في العامود (a) (كل خلية داخلها رابط صفحة انترنت )

 

يقوم  الماكرو بنسخ بيانات صفحة الويب ويلصقها ابتداءً من (B1)

 

تم ذلك لكن بشكل غير صحيح حيث ان البيانات تأتي بشكل افقى كل محتوى صفحة بجانب الاخرى وهذا لا يخدمني احتاج ان تكون البيانات مرتبة بالتسلسل

ابتداً من صفحة الانترنت الأولى "رابط الخلية A1" حتى صفحة الانترنت الاخيرة التي في "الخلية A164"

 

لتكون بالاخير بهذا الشكل

 

 

هذا اول شيء وهو الأهم

 

 

 

ثانياً  إن امكن

 

فعلياً انا لا احتاج كل بيانات الصفحة احتاج فقط جدول واحد وحاولت ان استخرج ID لهذا الجدول من صفحة الويب ID موحد لكل الصفحات وكما اتوقع هو احد هاؤلاء :D

 

(7_N0CVRI420G1910IKSQ9U2A20B5 - wpsPortletBody - tadawulPrintableSection - calibri-14 )

 

وأرجح ( wpsPortletBody ) لأنه الجدول الرئيسي، السؤال كيف يمكن استثناء كل البيانات الموجوده واستدعاء هذا الجدول من كل وصلة في العامود A

 

ثالثا ايضاً إن امكن

 

يكون هنالك فترة انتظار 5 ثواني بين كل استدعاء عشان الملف مايعلق بالجهاز

 

 

 

ثالثاً

 

هذا اول تعامل لي مع لغة VB وايضاً مع الإكسيل بتعمق لست ذو خبره كبيره، لذلك اجتهدت بما فتح الله علي آمل من يرى خطأ او كود لايلزم ان يكون في المايكرو يفعل مايرى صحيح حاولت جاهداً ان احول البيانات كلها Text والحمدلله زبطت بس اظفت سته وثلاثين طعش كود ما ادري وش سالفتهم :D

 

 

 

 

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

 

 

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

 

 

اخوكم/م.حامد

 

محاولة استدعاء 5 - مشكلة افقي.zip

روابط صفحات لافكار مايكرو ويب.zip

[H_BioMed]

يا اخوان هل من مجيب؟ معقوله ولا شخص يعرف يعدل الكود بما يلبي الإحتياج، على كل حال شكراً لكم يا عَرب.

[H_BioMed]

كيف يمكن الاستفادة من الكود التالي لتلبية الامر

 

Sub CopyRowsWithNumbersInG()
Dim X As Long
Dim LastRow As Long
Dim Source As Worksheet
Dim Destination As Worksheet
Dim RowsWithNumbers As Range
Set Source = Worksheets("name")
Set Destination = Worksheets("name")
With Source
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
For X = 2 To LastRow
If IsNumeric(.Cells(X, "E").Value) And .Cells(X, "E").Value <> "" Then
If RowsWithNumbers Is Nothing Then
Set RowsWithNumbers = .Cells(X, "E")
Else
Set RowsWithNumbers = Union(RowsWithNumbers, .Cells(X, "E"))
End If
End If
Next
If Not RowsWithNumbers Is Nothing Then
RowsWithNumbers.EntireRow.Copy Destination.Range("A4")
End If
End With
MsgBox "Data has been updated !!", vbExclamation + vbInformation, "Company Name"
End Sub

[H_BioMed]

لقيت اثنين ماكرو اتوقع انهم نفس الموضوع والله اعلم لكن مين يفيدنا بشرحهم

الأول

webquery()
startrow = 1
For i = 1 To 55
If i = 1 Then
curl = "URL;http://stats.espncricinfo.com/ci/engine/stats/index.html?class=2;filter=advanced;orderby=start;size=200;spanmax1=30+Jun+2012;spanmin1=01+Jan+2009;spanval1=span;template=results;type=batting;view=innings;wrappertype=print"
Else
curl = "URL;http://stats.espncricinfo.com/ci/engine/stats/index.html?class=2;filter=advanced;orderby=start;page=" & i & ";size=200;spanmax1=30+Jun+2012;spanmin1=01+Jan+2009;spanval1=span;template=results;type=batting;view=innings;wrappertype=print"
End If

With ActiveSheet.QueryTables.Add(Connection:=curl, Destination:=Range("$A$" & startrow))
.Name = "Webquery" & i
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "3"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
startrow = startrow + 202
Next i
End Sub

 

 

والثاني

 

Sub Macro3()

 

Dim Erw, Frw, Lrw

Frw = 1

Lrw = Range("A" & Rows.Count).End(xlUp).Row

For Erw = Frw To Lrw

 

With ActiveSheet.QueryTables.Add(Connection:= _

        "URL;" & Range("A" & Erw).Value, Destination:=Range("B" & Erw))

        .Name = ""

        .FieldNames = True

        .RowNumbers = False

        .FillAdjacentFormulas = False

        .PreserveFormatting = True

        .RefreshOnFileOpen = False

        .BackgroundQuery = True

        .RefreshStyle = xlInsertDeleteCells

        .SavePassword = False

        .SaveData = True

        .AdjustColumnWidth = True

        .RefreshPeriod = 0

        .WebSelectionType = xlSpecifiedTables

        .WebFormatting = xlWebFormattingNone

        .WebTables = "5"

        .WebPreFormattedTextToColumns = True

        .WebConsecutiveDelimitersAsOne = True

        .WebSingleBlockTextImport = False

        .WebDisableDateRecognition = False

        .WebDisableRedirections = False

        .Refresh BackgroundQuery:=False

    End With

    Next Erw

 

End Sub

 

ياليت احد يشرحهم لنا عشان نقدر نستفيد من اي واحد من الماكرو اللي فوق ..

 

وشكراً. .

[H_BioMed]

شكراً لكم، ياليت إن امكن يحذف الموضوع.

http://www.libstock.com/

 

 

 

[ا بو سليمان]

لا تستعجل على الحل بارك الله فيك 

 

اكيد بتلاقي  حل

[H_BioMed]

شكراً لتواجدك اخي زمزم، وانا لم استعجل لكن حتى الان كما ترى لايوجد اي تعاون من الاخوة، لا اعلم ما السبب :D لكن لاحرج في ذلك. نجتهد حتى نصل للحل بأنفسنا. بالتوفيق يا غالي

[H_BioMed]

سبحان الله والحمدلله ولا إله الا الله 

 

والسيسي اخذ الرئاسه، وانتم ماساعدتونا .:*_*:.