حسونة حسين

اضغط كليك يمين على الملف وهو مغلق ثم اختر Properties ثم اضغط على unblock كما بالصورة

اضغط على الشريط الاحمر Security risk واعمل trust

وعليكم السلام ورحمه الله وبركاته 1- قم بتحميل برنامج Selenium من الرابط او من ميديا فاير ثم قم بتسطيبه كأي برنامج 2- تفتح الكروم علي هذه الصفحه chrome://settings/help لنعرف ما هو اصدار الكروم ولنفرض اننا وجدناه كما لدي Version 109.0.5414.120 (Official Build) (64-bit) نأخذ الرقم 109.0.5414.120 ثم نبحث في الصفحه علي هذا الرقم او ما يقرب له ثم نفتح الصفحه لدي كان اقرب رقم له هو https://chromedriver.storage.googleapis.com/index.html?path=109.0.5414.25/ ثم نقوم بتحميل الملف المسمي chromedriver_win32.zip بعد التحميل تقوم بفك الضغط عنه باي برنامج ضغط ثم تقوم بنسخه للمسار التالي %LOCALAPPDATA%\SeleniumBasic\ لو المسار دا مش موجود هتلاقيه في مجلد %ProgramFiles%\SeleniumBasic\ لو المسار دا مش موجود هتلاقيه في مجلد %ProgramFiles(x86)%\SeleniumBasic\ وتوافق على الاستبدال بندخل على محرر الأكواد عن طريق Alt + F11 .. من القائمة Tools نضغط على References ونضيف المكتبة الخاصة بالأداة Selenium بنعلم علامة صح على Selenium Type Library ونضغط أوك كما بالشكل التالي ثم ضع هذا الكود في ملفك في الفورم المسماه UserForm1 Private Sub CommandButton14_Click() Dim bot As New WebDriver, Keys As New Selenium.Keys Dim i As Long, WS As Worksheet Set WS = ThisWorkbook.Sheets("البيانات") With bot .AddArgument "kiosk-printing" .Start "chrome", "https://apps.moe.gov.jo/App/Clearance/" For i = 2 To WS.Cells(Rows.Count, "C").End(xlUp).row .Get "/" .Wait 1000 .FindElementById("txtNumber").SendKeys WS.Cells(i, "C") .FindElementById("btnSearch").Click .Wait 1000 .ExecuteScript "window.print()" Next i End With End Sub

تفضل اخى Hassona229@gmail.com

السلام عليكم ورحمه الله وبركاته وبها نبدأ 1- مرحبا بك في المتتدي وفي المشاركه الاولي لك في المنتدي 2- هذا الموضوع يخالف قواعد المنتدي 3- ان كان باسوورد فتح الملف من الصعب معرفته

ارفعه على ميديا فاير وضع هنا الرابط http://mediafire.com

الشكر لله والحمد لله الذي بنعمته تتم الصالحات

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

وجزاكم مثله اخى الحمد لله الذي بنعمته تتم الصالحات

وعليكم السلام ورحمه الله وبركاته جرب هذا التعديل استبدل كودك بهذا الكود Option Explicit Sub GetData() Dim WhereToCopy As String, Col As String, CopyRange As String Dim dataWB As Workbook, currentWB As Workbook Dim WsData As Worksheet, WsResult As Worksheet, SH As Worksheet Dim FileName As String, lr As Long, i As Long Set currentWB = ThisWorkbook Set WsData = currentWB.Worksheets("List") Application.ScreenUpdating = False Application.EnableEvents = False For i = 2 To WsData.Cells(Rows.Count, 2).End(xlUp).Row FileName = WsData.Range("C" & i) & WsData.Range("B" & i) CopyRange = WsData.Range("D" & i) & ":" & WsData.Range("E" & i) WhereToCopy = WsData.Range("F" & i) Col = Mid(WsData.Range("G" & i), 2, 1) Set WsResult = currentWB.Sheets(WhereToCopy) Application.Workbooks.Open FileName, UpdateLinks:=False, ReadOnly:=True Set dataWB = ActiveWorkbook For Each SH In dataWB.Worksheets(Array("كشف", "بيانات اساسية")) ' هنا تحدد اسماء الشيتات المراد نسخها SH.Range(CopyRange).Copy lr = WsResult.Cells(Rows.Count, Col).End(xlUp).Row + 1 WsResult.Cells(lr, 1).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone Application.CutCopyMode = False Next SH dataWB.Close False Next i Application.ScreenUpdating = True Application.EnableEvents = True End Sub

وعليكم السلام ورحمه الله وبركاته وجزاكم مثله اخي على دعاؤك الطيب نعم عن طريق جعل اتجاه الفورم من اليمين للشمال من اعدادات الفورم كما بالصورة من هذا السطر في الكود ListBox1.ColumnWidths = "80 pt;80 pt;80 pt" عدل الارقام كما تشاء

ضعه في اليوزر فورم المسماه Userform1 التى في الملف الموجود في المشاركه الاولي لك كما في الصورة

وعليكم السلام ورحمة الله وبركاته اخى انا طلبت صورة لشكل النتائج وليس ان تقوم بعمل فورم جديد وترسل صورته صوره لشكل النتائج جرب هذا الكود لعله يفي بالمطلوب Option Explicit Private Sub UserForm_Initialize() ComboBox3.RowSource = "كشف!$AU$1:$AU$12" End Sub Private Sub CommandButton1_Click() Absence "day" End Sub Private Sub CommandButton3_Click() Absence "month" End Sub Sub Absence(All As String) Dim Ws As Worksheet, X, iCol As Long, r As Long, N As Long, jCol, I Set Ws = ThisWorkbook.Worksheets("كشف") ListBox1.Clear ListBox1.ColumnCount = 3 ListBox1.ColumnWidths = "80 pt;80 pt;80 pt" ListBox1.Font.Size = 14 ListBox1.Font.Bold = True If All = "day" Then If ComboBox2 = "" Or ComboBox3 = "" Or ComboBox4 = "" Then MsgBox "لا يوجد بيانات", vbExclamation: Exit Sub X = Application.Match(CDbl(CDate((ComboBox2 & "/" & ComboBox3 & "/" & ComboBox4))), Ws.Range("E7:AI7"), 0) If Not IsError(X) Then iCol = X + 4 jCol = iCol Else MsgBox "لا يوجد بيانات", vbExclamation: Exit Sub End If Else iCol = 5 jCol = 35 End If For I = iCol To jCol For r = 8 To Ws.Cells(Rows.Count, "D").End(xlUp).Row If Ws.Cells(r, I).Value <> "" Then ListBox1.AddItem ListBox1.List(N, 0) = Ws.Cells(r, 4).Value ListBox1.List(N, 1) = Ws.Cells(r, I).Value ListBox1.List(N, 2) = Ws.Cells(7, I).Value N = N + 1 End If Next r Next I End Sub

وعليكم السلام ورحمه الله وبركاته تفضل ضع هذا الكود في الفورم المسمي kh Private Sub ComboBox1_Change() Dim X, Ws As Worksheet Set Ws = ThisWorkbook.Worksheets("كشف") X = Application.Match(ComboBox1, Columns(4), 0) If Not IsError(X) Then TextBox5 = Ws.Cells(X, "Aj") TextBox6 = Ws.Cells(X, "Ak") TextBox7 = Ws.Cells(X, "AL") TextBox8 = Ws.Cells(X, "AM") TextBox9 = Ws.Cells(X, "AN") TextBox10 = Ws.Cells(X, "AO") TextBox11 = Ws.Cells(X, "AP") TextBox12 = Ws.Cells(X, "AQ") End If End Sub الطلب الثاني ماهي شكل النتائج التي تريد عرضها في الليست بوكس ؟

يتم التزويد علي حسب الاكواد التي تضعها وليس العواميد زودت 1 كود يعني ( 6 عامود ) يبقي تزود 1 في كل السطور التى اخبرتك بها زودت 2 كود يعني ( 12 عامود ) يبقي تزود 2 في كل السطور التى اخبرتك بها زودت 3 كود يعني ( 18 عامود ) يبقي تزود 3 في كل السطور التى اخبرتك بها تمام واضحه كده

هذه السطور arr = WSData.Range("A2:Q" & WSData.Cells(Rows.count, 1).End(xlUp).Row).Value ReDim Temp(1 To UBound(arr, 1) * 3, 1 To 4) For J = 0 To 2 P = P + 2 الي arr = WSData.Range("A2:AF" & WSData.Cells(Rows.count, 1).End(xlUp).Row).Value ReDim Temp(1 To UBound(arr, 1) * 5, 1 To 4) For J = 0 To 4 P = P + 4 بدل ال Q ضع اخر عامود عندك AF بدل ال * 3 ضع * 5 بدل ال For J = 0 To 2 ضع For J = 0 To 4 بدل P = P + 2 ضع P = P + 4 المصنف2.xlsm

وعليكم السلام ورحمه الله وبركاته تفضل ان شاء الله طلبك المصنف1.xlsm

وعليكم السلام ورحمة الله وبركاته اخى @MrNoon اضغط في اي مكان في هذا السطر ActiveSheet.Columns(1).Replace ChrW(8208), ChrW(45), xlPart, , , , True, False ثم اضغط زرار f5 من الكيبورد لكي يعمل الكود

ما هي اسم الصفحه

السلام عليكم ورحمه الله وبركاته وبها نبدأ اي موضوع يمكنك ذلك عن طريق كود vba كليك يمين على الصفحه (نسخة الزبون) والضغط على view code ثم نسخ هذا الكود ولصقه في حدث الشيت كما هو ولا تنسي يتم حفظ الملف بصيغه تقبل الماكرو xlsm او xlsb Private Sub Worksheet_Activate() Dim r As Range, i As Long Cells.EntireRow.Hidden = False For i = 7 To 34 If Cells(i, 2) = "" Then If r Is Nothing Then Set r = Cells(i, 2) Else Set r = Union(r, Cells(i, 2)) End If End If Next i If Not r Is Nothing Then r.EntireRow.Hidden = True End Sub

اخي احمد لتأكيد ان الملف لم يكن به مشكله في تشغيل الماكرو انما المشكله في اعدادات الماكرو لديك هذا فيديو يوضح هذا show.zip

اخى احمد الماكرو عندك غير مفعل لتفعيل الماكرو اتبع الخطوات كما بالصورة التاليه

اخى احمد حمل هذا الملف وشغله بدون اي تغيير للبيانات واخبرنا بالنتيجه هل النتائج صحيحه ام لا

اللهم اغفر له واعف عنه واكرم نزله ووسع مدخله واغسله بالماء والثلج والبرد ونقيه من الخطايا كما ينقى الثوب الابيض من الدنس اللهم ان كان محسنا فزد في احسانه وتجاوز عن سيئاته اللهم آنس وحشته اللهم اجعل قبره روضة من رياض الجنه اللهم ان عبدك الان بين يديك اللهم جازيه بالاحسان احسانا وبالسيئات عفوا ومغفرة ورضوانا اللهم ابدله دارا خيرا من داره واهلا خيرا من اهله اللهم اسكنه الفردوس الاعلى من الجنه اللهم ارزق اهله الصبر والسلوان

وجزاكم مثله اخى الكريم الحمد لله الذي بنعمته تتم الصالحات