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

التعامل مع بيانات الويب من خلال FTP: إستقبال بيانات من موقع معين سوف نقوم في هذا الدرس إن شاء الله بشرح طريقة جلب بيانات من الويب من دون اللجوء إلى المتصفح تنبيه: في هذا المجال ليس لدي أي خبرة و قد أعتمدت على البحث في الويب لجمع المعلومات. فلربما أخطئ في ذكر أحد المصطلحات لذلك من لديه دراية بهذا الموضوع و راني أخطئ فالرجاء أن يصوبني. بروتوكول FTP: FTP هي اختصار لمجموعة كلمات File Transfer Protocol، وهي تعني بروتوكول نقل الملفات، وهذه الخدمة هي إحدى تطبيقات TCP/IP التي تجعل من الممكن نقل الملفات بين أجهزة الحاسب الآلي المختلفة و المرتبطة بشبكة الإنترنت. ينقسم نقل الملفات إلى نوعين: 1 ـ تنزيل الملفات Download: وهو جلب الملفات من الكمبيوتر المضيف Host إلى جهازك المحلي Local. و نستخدم الأمر Get 2 ـ رفع الملفات Uplaod: وهو إرسال الملفات من جهازك المحلي Local إلى الجهاز الخادم Host. و نستخدم الأمر Put - كل طلب يرسل Request يتم من خلاله استقبال رد Response أوامر FTP: هذه بعض الأوامر المستخدمة في بروتوكول FTP و التي سنحتاجها أو سنعمل عليها. 1-Post: يستخدم لارسال معلومات من المستخدم مثال: إنشاء موضوع جديد أو تسجيل الدخول كل هذا عبر Post Request 2-Get: يستخدم هذا الأمر لتنزيل ملف ما من جهاز الخادم أو عرض صورة أو صفحة. مثال: أقوم بإرسال طلب و استقبل ردًا Response يحتوي على أكواد html للصفحة 3-Put: يستخدم لرفع الملفات إلى جهاز الخادم 4-Open: يستخدم لإنشاء إتصال جديد مع الخادم 6-Close: يستخدم لإنهاء الإتصال مع جهاز الخادم مثال تطبيقي: سوف نستخدم هذا الموقع: https://uk.investing.com/rates-bonds/financial-futures سوف نقوم بإستيراد بيانات جدول من هذه الصفحة إلى جدول موجود في الملف و قد ربطه بمربعات نص لنلاحظ تنزيل البيانات هذا الكود المستخدم: Dim html As HTMLDocument, hTable As HTMLTable Dim Url As String Url = "https://uk.investing.com/rates-bonds/financial-futures" Set html = New HTMLDocument With CreateObject("MSXML2.XMLHTTP") .Open "GET", Url, False .send html.body.innerHTML = .responseText End With Set hTable = html.getElementById("cr1") For i = 1 To hTable.rows.length - 1 DoCmd.GoToRecord , , acNewRec Me.id = hTable.rows(i).cells(1).innerText Me.dd = hTable.rows(i).cells(2).innerText Me.t1 = hTable.rows(i).cells(3).innerText Me.t2 = hTable.rows(i).cells(4).innerText Me.t3 = hTable.rows(i).cells(5).innerText Me.t4 = hTable.rows(i).cells(6).innerText Me.t5 = hTable.rows(i).cells(7).innerText Me.t6 = hTable.rows(i).cells(8).innerText Next i شرح الكود: تعريف كائنات html Dim html As HTMLDocument, hTable As HTMLTable إنشاء إتصال جديد عبر السرفر MSXML2.XMLHTTP و إرسال الطلب: With CreateObject("MSXML2.XMLHTTP") .Open "GET", Url, False .send إستقبال الرد على شكل صفحة html: html.body.innerHTML = .responseText استخراج البيانات من الجدول الموجود في الرد الذي استقبلناه وقد قمنا بشرح التعامل مع الجداول في الجزء الأول بالتفصيل: Set hTable = html.getElementById("cr1") For i = 1 To hTable.rows.length - 1 DoCmd.GoToRecord , , acNewRec Me.id = hTable.rows(i).cells(1).innerText Me.dd = hTable.rows(i).cells(2).innerText Me.t1 = hTable.rows(i).cells(3).innerText Me.t2 = hTable.rows(i).cells(4).innerText Me.t3 = hTable.rows(i).cells(5).innerText Me.t4 = hTable.rows(i).cells(6).innerText Me.t5 = hTable.rows(i).cells(7).innerText Me.t6 = hTable.rows(i).cells(8).innerText Next i استخدام ftp.rar

عادي مفيش مشكلة بس التجميع هيكون : بدلاً من السيد/ أحمد ، العقيد/ وليد ، والوزير/ سيد ستجد : 4/ أحمد ، 14/وليد ، 22/ سيد لأن الجدول المشار إليه فيه أكواد الرتب أو اللقب وليس أسمائها ولحل مؤقت للمشكلة يجب تعديل الدالة وعمل ربط مع جدول آخر به كود اللقب واسم اللقب ، كما بالمرفق NewDB3.accdb

تفضل . هذا االكود Private Sub MultiPage1_Change() Select Case MultiPage1.Value Case 0 Sheets("sheet1").Activate Case 1 Sheets("sheet2").Activate Case 2 Sheets("sheet3").Activate Case 3 Sheets("sheet4").Activate End Select End Sub test1.xlsm

نورت المنتدى ابو احمد كل عام وانتم بخير

بارك الله فيك اخي احمد الفلاحجي و جزاك خير الجزاء على سؤالك الحمد لله كلنا بخير دامكم بخير و صحه ... و انا كذلك سعيد برؤيتكم اخي العزيز .. اخي zoom10 اهلا بك ... ارفق مثال من طرفك للعمل عليه حتى اتمكن من معرفة الخطأ

Calc_Data.rar

هلا اخي جرب المرفق test.accdb

استنادا للدالة التي أوردها أستاذ أحمد الفلاحجى سابقاً فانظر المرفق NewDB2.accdb

جرب هذا الكود Option Explicit Dim La%, x% Dim SW As Worksheet Sub find_in(Rg As Range) Dim obj As Object Dim Mth, i, p, k% With Rg .Characters(1, Len(Rg)).Font.Color = 1 .Font.Bold = False End With Set obj = CreateObject("Vbscript.Regexp") With obj .Pattern = "\b(in)\b" .Global = True .ignorecase = True .MultiLine = True End With If obj.test(Rg) Then Set Mth = obj.Execute(Rg) For i = 0 To Mth.Count - 1 p = InStr(1 + k, Rg, Mth(i)) Rg.Characters(p, 2).Font.ColorIndex = 5 Rg.Characters(p, 2).Font.Bold = True k = Len(Rg) - p Next End If End Sub '++++++++++++++++++++++++++++++++++++ Sub Colorize() Set SW = Sheets("Sheet1") La = SW.Cells(Rows.Count, 1).End(3).Row For x = 1 To La If SW.Cells(x, 1) <> vbNullString Then Call find_in(SW.Range("A" & x)) End If Next End Sub '++++++++++++++++++++++++++++++++ Sub reset() Set SW = Sheets("Sheet1") La = SW.Cells(Rows.Count, 1).End(3).Row For x = 1 To La If SW.Cells(x, 1) <> vbNullString Then With SW.Cells(x, 1) .Characters(1, Len(.Value)).Font.Color = 1 .Font.Bold = False End With End If Next End Sub الملف مرفق Saerch_In.xlsm

السلام عليكم في حدث عند الخطأ للنموذج ضع الكود التالي : Const conErrRequiredData = 3314 If DataErr = conErrRequiredData Then MsgBox ("لا يمكن ترك الفهرس فارغ") Response = acDataErrContinue Else Response = acDataErrDisplay End If غير نص الرسالة بما تريد بالتوفيق

وعليكم السلام-تفضل ............ وهذه الصورة توضح كيفية عمل قائمة منسدلة TEST-STORE1.xlsx

ربما ينال الاعجاب هذا الملف 1-لا يتم تكرار الأسماء 2-تحديد المجموع لكل اسم الكود Sub transfer_data_with_sum() Dim S1 As Worksheet, S2 As Worksheet Dim Rg1 As Range, x As Range Dim Dic As Object Set S1 = Sheets("ورقة1"): Set S2 = Sheets("ورقة2") If S2.Range("A1").CurrentRegion.Rows.Count > 1 Then _ S2.Range("A1").CurrentRegion.Offset(1) _ .Resize(S2.Range("A1").CurrentRegion.Rows.Count - 1) _ .Clear Set Dic = CreateObject("Scripting.Dictionary") Set Rg1 = S1.Range("A1").CurrentRegion If Rg1.Rows.Count = 1 Then Exit Sub Set Rg1 = Rg1.Offset(1).Resize(Rg1.Rows.Count - 1) For Each x In Rg1.Columns(2).Cells Dic(x.Value) = Val(Dic(x.Value)) + Val(x.Offset(, 1)) Next x If Dic.Count = 0 Then Exit Sub With S2.Range("B2").Resize(, Dic.Count) .Value = Dic.keys .Offset(1) = Dic.Items End With S2.Range("A2") = "الإسم": S2.Range("A3") = "المجموع" With S2.Range("a2").Resize(2, S2.Range("A1").CurrentRegion.Columns.Count) .InsertIndent 1: .Borders.LineStyle = 1 .Font.Size = 14: .Font.Bold = True .Rows(1).Interior.ColorIndex = 19 .Rows(2).Interior.ColorIndex = 28 End With End Sub الملف مرفق Mashri3 _with_Sum.xlsm

الكود الصحيح Private Sub TextBox1_Change() Application.EnableEvents = False If ActiveSheet.FilterMode Then _ ActiveSheet.Range("A3").AutoFilter If ActiveSheet.TextBox1.Text <> "" Then Range("$A$3").AutoFilter field:=2, _ Criteria1:="=" & ActiveSheet.TextBox1.Text End If Application.EnableEvents = True End Sub

السلام عليكم ورحمة الله لعلها تكون قائمة من ضمن القوائم التي يتم عليها "الفرز الخاص"... إذا كانت موجودة من ضمن هذه القوائم فيكفي القيام بحدفها... راجع الملف التنفيذي المرفق (وضعت خطأ في القائمة بدل حرف "الميم" حرف "الفاء").. 555.rar

val([اسم حقل البنين])+val([اسم حقل البنات])

الحمد الله تم عمل الكود بنجاح بارك الله بجهودكم

ياخي اصلن الواحد لا يعرف ماذا يقول لكم لكي يشكركم اسئل الله ان يمدك بالصحة والعافية والعلم استاذي الرائد77. فعلا حل عبقري و مميز .. تحياتي لشخصك الكريم

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

ربما ينفع هذا الكود Private Sub CommandButton1_Click() Dim n%, Ro%, i%, x% Dim a, b As Boolean, c As Boolean Dim st1$, st2$, st3$ st1 = "سدد": st2 = "انجز": st3 = "تم" CommandButton2_Click n = Sheets.Count For i = 1 To n With Sheets(i) .Cells.EntireRow.Hidden = False Ro = .Cells(Rows.Count, "J").End(3).Row For x = 1 To Ro a = Cells(x, "J") = st1: b = .Cells(x, "B") = st2 c = .Cells(x, "B") = st3 If b Or c Then .Cells(x, "B").EntireRow.Hidden = True If a Then .Cells(x, "J").EntireRow.Hidden = True Next x End With Next i Unload Me End Sub '++++++++++++++++++++++++++++++++++++++ Private Sub CommandButton2_Click() Dim M%, t% M = Sheets.Count For t = 1 To M Sheets(t).Cells.EntireRow.Hidden = False Next t Unload Me End Sub Hide_Rows.xlsm

طبعا لا يوجد الا بمقابل مادى ... شوف هذا الفيديو بنفسك https://www.youtube.com/watch?v=pIiNnO-jVJM وكذلك كما بهذا الرابط برنامج إدارة معارض السيارات

الاخ الفاضل @محمود1980 هل يحقق الملف المرفق ماكنت تطلبه برجاء الافادةعن وجود مطلوب اخر وبرجاء الدعاء لاخيك بظهر الغيب مكتبة.xlsb

كيفك اخى واستاذى العزيز @يوسف أحمد ازى صحتك والله سعيد انى شوفتك ان شاء الله تكون دائما بخير عودا حميدا

اذا كان عندك زرين واحد بالكود وواحد بالماكرو MMM(1).accdb

استاذي الفاضل ابو تراب الله يبارك فيك ويحفظك نعم هذا هو المطلوب جزاك الله كل خير اسأل الله جل وعلا ان يمن عليك بالصحة والعافية والخير والبركات

السلام عليكم محاولة الحل باستعمال الدالة OFFSET بدلا من الدالة VLOOKUP بمعادلات صفيف... 2 (7).xlsx

مثال2.accdb

جرب هذا الملف ( الصفحة Salim ) الكود Option Explicit Sub Salim_macro() Application.ScreenUpdating = False Dim lrB% lrB = Cells(Rows.Count, 2).End(3).Row Range("H5:K500").Clear Range("B5:E" & lrB).Copy With Range("H5") .PasteSpecial (12) .PasteSpecial (8) .PasteSpecial (xlPasteFormats) With .Offset(, 2).Resize(lrB - 4) .SpecialCells(4).Formula = "=J5" .Interior.ColorIndex = 6 End With .CurrentRegion.Borders.LineStyle = 1 .CurrentRegion.InsertIndent 1 End With Application.CutCopyMode = False Range("J5").Select Application.ScreenUpdating = True End Sub الملف مرفق Copy_my_data.xlsm

الشكر لله ثم لاخواننا واساتذتنا جزاهم الله خيرا نعم يمكن عمل استعلام من استعلام بالنسبه لطريقه الاستعلام qryAllUsers افتحه فى وضع التصميم هتلاقى الاستعلام ده مبنى على الاستعلام q خدنا فيه حقل carName والحقل الاخر مستدعيين فيه الموديول Horizontal qryAllUser: Horizontal("q";"carName";"UserName";[carName]) الموديول فيه 4 براميترات اسم الجدول q اسم الحقل اللى هنجمع البيانات عليه carName اسم الحقل المطلوب تجميع البيانات منه UserName اسم الحقل لشرط التجميع carName واعتذر لو فى تقصير بالتوفيق اخى

جرب البرنامج التالي https://www.ssesetup.com/

الاخ فارس النايلي ملاحظة قبل تنفيذ التجميع : يجب ان يكون ملف التجميع موجود في نغس فلدر ملفات المصدر وسوف يقوم ملف التجميع بتجميع كل شيتات ملفات المصدر الموجودة في نغس الفولدر شاهد المرفق My_Folder_Xlsm.rar