الـعيدروس

السلام عليكم وهذه طريقه اخرى العمليه تتم عبر زر تحياتي Ali_Hid.rar

السلام عليكم رأيت من طرحك للموضوع تريد ان تتعلم فلم ارفق الملف وتركت التعديل عليك تفضل المرفق تعديل وحذف بيانات _11.rar

عند محاولة تحميل مرفقك يظهر الخطاء التالي؟؟

راجع كود "TextBox7_Change" لايوجد اي تعيين للعمود 9 في الليست بوكس لذا قم بإدراج السطر التالي ليأخذ عنوان خلية نتيجة البحث ويدرجها في العمود 9 لليست بوكس ListBox9.List(V, 9) = q.Address الصقه قبل السطر V = V +1 ثم الغي تحديد نوع القيم في كود "ListBox9_Click" مثال ComboBox3.Text حطيته يستقبل نص .Range(DADA).Value ويساوي قيمة ؟ Private Sub ListBox9_Click() Sheets("sheet2").Select Dim DADA As String Dim MySh As Worksheet 'On Error GoTo 1 DADA = ListBox9.List(ListBox9.ListIndex, 9) Set MySh = Sheets("sheet2") With MySh .Application.Range(DADA).Activate ComboBox3.Text = .Range(DADA).Value ComboBox2.Text = .Range(DADA).Offset(0, 1).Value TextBox4.Text = .Range(DADA).Offset(0, 2).Value TextBox5.Text = .Range(DADA).Offset(0, 3).Value TextBox6.Text = .Range(DADA).Offset(0, 4).Value TextBox7.Text = .Range(DADA).Offset(0, 5).Value ComboBox1.Text = .Range(DADA).Offset(0, 6).Value End With End Sub لذا ليس ضروري تحديد قيمة اتركه بدون وفعل سطر الخروج من الكود في حالة حدوث خطاء 'On Error GoTo 1 وهذا الكود حدث ListBox9_Click بعد تعديل الاخطاء المذكوره اعلاه Private Sub ListBox9_Click() Sheets("sheet2").Select Dim DADA As String Dim MySh As Worksheet On Error GoTo 1 DADA = ListBox9.List(ListBox9.ListIndex, 9) Set MySh = Sheets("sheet2") With MySh .Application.Range(DADA).Activate ComboBox3 = .Range(DADA) ComboBox2 = .Range(DADA).Offset(0, 1) TextBox4 = .Range(DADA).Offset(0, 2) TextBox5 = .Range(DADA).Offset(0, 3) TextBox6 = .Range(DADA).Offset(0, 4) TextBox7 = .Range(DADA).Offset(0, 5) ComboBox1 = .Range(DADA).Offset(0, 6) End With 1 End Sub

السلام عليكم جميل جداً اخي محمد حسن المحمد الاكسل مليئ بالاختصارات ان اتقنتها وحفظتها ستختصر لك الوقت الكثير ان سمح لي الوقت سوف ارفق بعض منها في موضوعك بارك الله فيك تقبل مروري

السطر السابق للتعبير عن الخليه التي تحتوي على بوردر الجانب الايمن عموماً جرب التعديل التالي مع اضافة شرط استثناء السطر اذا كانت الخليه المجاوره اي العمود A وجد فيها كلمة "كشف" Sub Ali_A() Dim Ws As Worksheet, L Dim Rng As Range Dim Rn As Range Dim Rx$ On Error Resume Next Set Ws = Sheets("salary"): Tx = "كشف" L = Split(Ws.UsedRange.Address, "$")(4) For Each Rng In Union(Ws.Range("C8:F" & L), Ws.Range("AO8:AO" & L)) If Rng.Borders(xlEdgeRight).LineStyle <> -4142 _ And Not Trim(Ws.Cells(Rng.Row, 1)) Like "*" & Tx & "*" Then If Not Rng Is Nothing Then If Rn Is Nothing Then Set Rn = Rng Else Set Rn = Union(Rn, Rng) End If End If End If Next With Sheets("Total") If Not Rn Is Nothing Then Rn.Copy Application.ScreenUpdating = False Sheet1.Activate .[F8].Select .Paste Application.ScreenUpdating = True End If End With Application.CutCopyMode = False Set Rn = Nothing Set Rng = Nothing End Sub تحياتي اخي ياسر العربي كفيت ووفيت الظاهر نشرت الرد وانا اكتب الرد تحياتي لك

الاخ الحبيب سعد عابد تسلم على مرورك الكريم وكلماتك الطيبه المشجعه تقبل تحياتي وشكري

السلام عليكم Private Sub ListBox1_Click() ''********************* '' الذهاب الى الورقة المسماه ورقة1 Sheets("ورقة1").Select '' متغير لحفظ قيمة نصيه Dim DADA As String ''MySh متغير لورقة في المصنف للتعبير عن الورقة في الكود بمسمى Dim MySh As Worksheet 'On Error GoTo 1 '' اخذ القيمة من العمود الـ 9 في الليست بوكس والتي هيا عنوان الخليه من السطر المحدد في الليست بوكس DADA = ListBox1.List(ListBox1.ListIndex, 9) ''كتعبير عن الورقة المسماه "ورقة1" MySh تعين المتغير Set MySh = Sheets("ورقة1") ''With ادرج في اطار Myshلتعدداستخدام متغير '' للتعبير عن المتغير بأكثر من سطر دون ذكر المتغير بكل سطر '' . مع التعبير بعلامة With MySh ''للذهاب للخليه المعنيه في البحث Range في تعبير DADA ادراج متغير '' Range.address حفظ فيه عنوان الخليه DADA اعتباراً ان متغير .Application.Range(DADA).Activate ''ComboBox3 وحقظه في DADA اخذ قيمة الخليه من متغير ComboBox3.Text = .Range(DADA).Value ''ComboBox2 مع ازاحه بقدر عمود وحقظه في DADA اخذ قيمة الخليه من متغير ''B1 مع ازاحة عمود ستصبح الخليه المعنيه A1 اي اذا فرضنا الخليه هيا ComboBox2.Text = .Range(DADA).Offset(0, 1).Value ''TextBox4 مع ازاحه بقدر عمودين وحقظه في DADA اخذ قيمة الخليه من متغير TextBox4.Text = .Range(DADA).Offset(0, 2).Value ''TextBox5 مع ازاحه بقدر 3 اعمده وحقظه في DADA اخذ قيمة الخليه من متغير TextBox5.Text = .Range(DADA).Offset(0, 3).Value ''TextBox6 مع ازاحه بقدر 4 اعمده وحقظه في DADA اخذ قيمة الخليه من متغير TextBox6.Text = .Range(DADA).Offset(0, 4).Value ''TextBox7 مع ازاحه بقدر 5 اعمده وحقظه في DADA اخذ قيمة الخليه من متغير TextBox7.Text = .Range(DADA).Offset(0, 5).Value ''ComboBox1 مع ازاحه بقدر 6 اعمده وحقظه في DADA اخذ قيمة الخليه من متغير ComboBox1.Text = .Range(DADA).Offset(0, 6).Value '' Myshالخروج من اطار متغير End With ''********************* End Sub

السلام عليكم اشكرك اخي الحبيب ياسر خليل على مرورك العطر صحيح الملاحظه التي ذكرتها سقط سهواً تقبل تحياتي وشكري تم تعديل المشاركه السابقه مع الشكر والتقدير

السلام عليكم تفضل اخي الخليفه الاول فاتورة_111.rar

السلام عليكم تفضل Sub Ali_Rows() Dim Rng As Range, Rng_a As Range Dim Lr& With ActiveSheet Application.ScreenUpdating = False Application.EnableEvents = True Lr = .UsedRange.SpecialCells(xlCellTypeLastCell).Row For Each Rng In Range(Cells(5, 1), Cells(Lr, 1)) If Rng = Empty Or Trim(.Cells(Rng.Row, 15)) = "الاجمالى" _ Or Trim(CStr(Rng)) = "دائن" Then If Not Rng Is Nothing Then If Rng_a Is Nothing Then _ Set Rng_a = Rng Else Set Rng_a = Union(Rng_a, Rng) End If Next If Not Rng_a Is Nothing Then Application.DisplayAlerts = False ''************************ Rng_a.EntireRow.Delete ''************************ Application.DisplayAlerts = True End If Set Rng = Nothing:Set Rng_a = Nothing Application.ScreenUpdating = True Application.EnableEvents = False End With End Sub

اذا كان ملفك كجدول واحد الغي الحلقه التكراريه ليصبح الكود كالتالي Sub Ali_Prnt() Dim R As Long Dim Ar Dim Rn As Range, Rn1 As Range Dim Sh As Worksheet '********************************************** Call YK_Start On Error Resume Next Set Sh = ActiveSheet With Sh II = .PageSetup.PrintArea 'For R = 1 To .VPageBreaks.Count Ro = .VPageBreaks(1).Location.Row Cl = .VPageBreaks(1).Location.Column Ar = .Range(.PageSetup.PrintArea) Lr = UBound(Ar, 2) + 1 Rw = UBound(Ar, 1) + 1 Set Rn = .Range(Cells(Ro, 2), Cells(Rw, Cl - 1)) Set Rn1 = .Range(Cells(Ro, Cl), Cells(Rw, Lr)) Ali_Rest With .PageSetup .PrintArea = Rn.Address .RightHeader = Sheets("الاساسية").Range("A5").Value & Chr(13) & Sheets("الاساسية").Range("B5").Value .LeftHeader = Sheets("الاساسية").Range("A7").Value & Chr(13) & Sheets("الاساسية").Range("B7").Value .RightFooter = Sheets("الاساسية").Range("A10").Value & Chr(13) & Sheets("الاساسية").Range("B10").Value .CenterFooter = Sheets("الاساسية").Range("A11").Value & Chr(13) & Sheets("الاساسية").Range("b11").Value End With .PrintPreview Ali_Rest With .PageSetup .PrintArea = Rn1.Address .LeftHeader = Sheets("الاساسية").Range("A8").Value & Chr(13) & Sheets("الاساسية").Range("B8").Value .LeftFooter = Sheets("الاساسية").Range("B6").Value & Chr(13) & Sheets("الاساسية").Range("A6").Value .CenterHeader = Sheets("الاساسية").Range("A9").Value End With .PrintPreview Ali_Rest ' Next R .PageSetup.PrintArea = II End With Set Sh = Nothing Call YK_End '********************************************** On Error GoTo 0 End Sub Private Sub Ali_Rest() Call YK_Start With Sheets("عام") With .PageSetup .LeftHeader = "" .RightHeader = "" .CenterHeader = "" .LeftFooter = "" .RightFooter = "" .CenterFooter = "" End With End With Call YK_End End Sub

يرجاء توضيح اسماء الصفحات المذكورة في الكود مالاوراق التي تقصدها وان شاء الله نعدل على الكود كي يخف نوع ما Sheets(1) Sheets(7) Sheets(11) Sheets(5) تحياتي

السلام عليكم جرب الكود التالي مثل ماتفضل اخي الحبيب ياسر خليل ملفك ملخبط شويات كان بالامكان عمل ورقة لكل عميل اريح لك Sub Ali_copy() Dim Sht As Worksheet, Ws As Worksheet Dim Num, C, R, Cl, Rw Set Sht = Sheets("الباب الثاني") Set Ws = Sheets("بيان") '=== Ali_Sp False '=== Ws.Range("Q3:Aq3").Copy Sht.Range("A" & Sht.Cells(191, 1).End(xlDown).Row + 1).PasteSpecial xlPasteValues Sht.[A192:AA192].Copy Sht.[A45].PasteSpecial xlPasteValues With Sht For C = 30 To 240 If CStr(.Cells(280, C)) Like "*" & "البند" & "*" Then Num = Trim(Replace(Split(.Cells(280, C), "/")(1), "/", "")) For R = 245 To .Cells(245, 1).End(xlDown).Row If Trim(.Cells(R, 1)) = Num Then Rw = .Cells(R, 1).Row: Cl = .Cells(280, C).Column - 1 With .Cells(.Cells(.Rows.Count, Cl).End(xlUp).Row, Cl) .Offset(1, 0) = Sht.Cells(Rw, 1) .Offset(1, 1) = Sht.Cells(Rw, 2) .Offset(1, 2) = Sht.Cells(Rw, 3) .Offset(1, 4) = Sht.Cells(Rw, 5) .Offset(1, 5) = Sht.Cells(Rw, 6) .Offset(1, 6) = Sht.Cells(Rw, 7) .Offset(1, 7) = Sht.Cells(Rw, 8) End With End If Next End If Next End With '=== Ali_Sp True '=== Set Sht = Nothing Set Ws = Nothing End Sub Private Function Ali_Sp(Bl As Boolean) With Application .Calculation = IIf(Bl, -4135, -4135) .EnableEvents = Not Bl .ScreenUpdating = Bl End With End Function

السلام عليكم حفز امان الماكرو في جهازك الاخر شاهد الفيديو بالمرفق تفعيل_الماكرو.rar

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

اضف هذا السطر اول الكود وجرب On Error Resume next

السلام عليكم اخي الكريم ابو عبدالملك اعلم ان التعديل يأخذ جهد مضاعف اذا اردت التفاعل من الاعضاء مع طرحك يفضل طلب عمل منفصل لكي يسهل العمل على من اراد المشاركه عموماً اطلعت على ملفك لاحظت ان عمود V في التقرير الشهري فارغ وانت طرحت التالي فكيف نحطه كشرط ضمن الكود وهو فارغ فابطبع لن ينفذ شيء الكود ! تفضل الكود التالي بعد ان تضيف الشهر في عمود V بصفحة التقرير الشهري قم بتشغيله كي يعمل معك Sub Ali_Am() Dim Sht As Worksheet Dim R&, Tx$ Set Sht = Sheets("مجمع النتائج الشهرية") ''************************************** With Sheets("التقرير الشهري") For R = 2 To LR Tx = CStr(Sht.Cells(R, 3)) If Tx = .Cells(R, 3) Then If Ch_Month(.Cells(R, "V")) = CStr(Sht.Cells(R, "V")) Then If SH.Cells(R, "R") >= 60 Then .Cells(R, "L") = Sht.Cells(R, "N") .Cells(R, "M") = Sht.Cells(R, "O") ElseIf SH.Cells(R, "R") < 60 Then .Cells(R, "L") = Sht.Cells(R, "L") .Cells(R, "M") = Sht.Cells(R, "M") End If End If End If Next End With ''************************************** End Sub Private Function Ch_Month(Mn As String) Dim Mm& Dim Tn$, X$ For Mm = 1 To 12 Tn = MonthName(Mm) If Tn = Trim(Mn) Then Mm = Mm - 1 X = MonthName(Mm) Exit For End If Next If Mm Then Ch_Month = X End Function لم اجرب الكود اذا به اي اخطاء اشعرنا وان شاء الله لن يقصر معك الجميع تحياتي

السلام عليكم جرب التالي Sub Ali_A() Dim Ws As Worksheet, L Dim Rng As Range Dim Rn As Range Set Ws = Sheets("salary") L = Split(Ws.UsedRange.Address, "$")(4) For Each Rng In Union(Ws.Range("C8:C" & L), Ws.Range("AM8:AM" & L)) If Rng.Borders(xlEdgeRight).LineStyle <> -4142 Then If Not Rng Is Nothing Then If Rn Is Nothing Then Set Rn = Rng Else Set Rn = Union(Rn, Rng) End If End If End If Next With Sheets("Total") If Not Rn Is Nothing Then Rn.Copy .[J8].Select .Paste End If End With Application.CutCopyMode = False Set Rn = Nothing Set Rng = Nothing End Sub

السلام عليكم لا عليك اخي مصطفى محمود نحن بالخدمة طالما السؤال في حدود المعرفه جرب المرفق التكرارفي الصفحةالزوجية_111.rar

شاهد المرفق اكتب تاريخ البداية والنهايه في المربعين ع الفورم وانقر بحث تحياتي الرشيدى _ إحصاء_111.rar

صحيح اخي ياسر جزاك الله كل خير التعديل في محله

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

السلام عليكم بالامكان عمل ذلك برأس وتذيل الصفحه حدد صوره كإطار وثبته في رأس الصفحه وسيظهر لك كما هو بكل الصفحات تحياتي

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