ياسر خليل أبو البراء

جرب السطر التالي Sub Test() Sheet2.Range("G2") = Application.Match(Sheet2.Range("A1"), Sheet1.Range("A1:A" & Sheet1.Cells(Rows.Count, "A").End(xlUp).Row), 0) End Sub

السلام عليكم يوجد مشكلة بالنسبة لتصفح صفحات المنتدى .. لا يمكنني الانتقال لصفحة رقم 2 أو 3 أو أي صفحة أخرى فقط الصفحة رقم واحد هي المتاحة أرجو الاهتمام بالمشكلة

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

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

أخي الحبيب إبراهيم عوداً حميداً ..طالت غيبتك علينا يرجى مزيد من التوضيح ..الترتيب على أي أساس ..هل الترتيب تصاعدي .. تنازلي ..ترتيب مخصص ؟؟ أعتقد أنه ترتيب تنازلي ...لم أستطع تحميل المرفق يرجى إعادة رفعه مرة أخرى

أعتقد حتى لو وجدت طريقة لابد من عمل ريستارت للجهاز ..

أخي الكريم جرب الكود التالي Sub SUMSpecificSheets() Dim I As Long, Counter1 As Double, Counter2 As Double Dim lStart As Long, lEnd As Long If Not IsNumeric(Range("F2")) Or Not IsNumeric(Range("H2")) Or IsEmpty(Range("F2")) Or IsEmpty(Range("H2")) Then MsgBox "Invalid Input", 64: Exit Sub Application.ScreenUpdating = False With Sheets("total") .Range("A2:B2").ClearContents lStart = Application.Min(.Range("F2"), .Range("H2")) lEnd = Application.Max(.Range("F2"), .Range("H2")) For I = lStart To lEnd If Evaluate("=ISREF('" & I & "'!A1)") Then Counter1 = Application.Sum(Counter1, Sheets(I).Range("A2")) Counter2 = Application.Sum(Counter2, Sheets(I).Range("B2")) .Range("A2") = Counter1: .Range("B2") = Counter2 Else MsgBox "The Sheet " & I & " Is Not Existed", 64 End If Next I End With Application.ScreenUpdating = True End Sub

أخي الغالي ياسر فتحي جرب الكود التالي جيداً Sub PullUniques() Dim clnMyUniqueList As New Collection Dim lngMyCol As Long Dim lngMyRow As Long Application.ScreenUpdating = False For lngMyCol = 2 To 25 Step 2 For lngMyRow = 5 To Cells(Rows.Count, lngMyCol).End(xlUp).Row On Error Resume Next clnMyUniqueList.Add Item:=Cells(lngMyRow, lngMyCol).Value, Key:=CStr(Cells(lngMyRow, lngMyCol).Value) If Err.Number = 0 Then Cells(Rows.Count, lngMyCol + 25).End(xlUp).Offset(1, 0).Value = Cells(lngMyRow, lngMyCol).Value Cells(Rows.Count, lngMyCol + 26).End(xlUp).Offset(1, 0).Value = Cells(lngMyRow, lngMyCol + 1).Value End If On Error GoTo 0 Next lngMyRow Next lngMyCol Set clnMyUniqueList = Nothing Application.ScreenUpdating = True End Sub Customers New Only End.rar

أعتقد أن حل الأخ الحبيب عبد الله يفي بالغرض يمكن تطبيق المعادلات في الجدول الثاني وهكذا ترحيل بشرط.rar

أخي الكريم ياسر أشعر أني تهت بالموضوع الآن هل المطلوب قيمة المبيعات تنقل مع اسم العميل .. ماذا لو كانت قيمة المبيعات مختلفة في المرة الثانية أو الثالثة عنها في الأولى ...؟؟؟؟؟

أخي الحبيب ياسر لم أفهم ..هل تم المطلوب أم أنه ما زال هناك بعض التعديلات المطلوبة ..يرجى التوضيح ..ردك بطلب التعديل على أي أساس .. من المفترض أن الكود يعمل الآن ويقوم بما طلبت ... أنا في غاية الإرهاق ولا أستطيع التركيز الآن اعذرني

جرب الكود التالي Sub PullUniques() Dim A, I As Long, J As Long, N As Long, LR As Long With Sheets("Sheet1") LR = .Columns("B:Y").Find("*", , , , xlByRows, xlPrevious).Row A = .Range("B5:Y" & LR).Value With CreateObject("Scripting.Dictionary") .CompareMode = 1 For J = 1 To UBound(A, 2) Step 2 For I = 1 To UBound(A, 1) If Len(A(I, J)) Then If Not .Exists(A(I, J)) Then .Item(A(I, J) & A(I, J + 1)) = Empty: N = N + 1 If N <> I Then A(N, J) = A(I, J): A(I, J) = Empty Else A(I, J) = Empty End If End If Next I N = Empty Next J End With .Range("AA5").Resize(UBound(A, 1), UBound(A, 2)).Value = A End With End Sub

الكود يعمل معي في ملفك أيضاً .حدد المشكلة بشكل أكثر دقة للوقوف على الخطأ إذا وجد

أخي الكريم يرجى وضع النتائج المتوقعة كمثال ..حيث أن المطلوب غير واضح الترحيل بشرط واضح ..اسم البنك سيكون في الخلية C2 في الورقة المراد الترحيل إليها .. سيتم ترحيل الاسم (واضح) .. واجب صرفه هل تقصد الصافي؟ ماذا تقصد بأن يظهر اسم البنك الآخر أي بنك آخر وكيف أعرف البنك الآخر ........؟؟؟؟؟

أخي الكريم هل اطلعت على التوجيهات يوضع الكود بين أقواس الكود يذكر ما المطلوب من الموضوع بعنوان معبر وليس عنوان عام .. مثال : شرح لكود الترحيل لكشف حساب جديد (مجرد مثال) في الرد الأول لم يكن هناك مرفق ..

أخي الكريم يرجى مزيد من التوضضيح ما هي الخلايا التي سيتم وضع خانة اختيار بها؟ لا يعقل على الإطلاق وضع أزرار اختيار في كل العمود .. وهل أزرار الاختيار مرتبطة برقم الصف أم ماذا؟

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

أخي الكريم تفضل ملفك Files.rar

أخي الكريم أعتقد أنك تطلب ترتيب البيانات على أساس العمود السادس في ورقة 2013 مثلاً ..حدد الخلية A1 وبعدين روح للتبويب Data هتلاقي أمر Sort فرز وترتيب ... شيل علامة الصح بجانب الخيار My data has headers لأن بيااناتك مفيهاش عناوين .. من الحقل Sort By اختار Column F المراد ترتيب البياانات على أساسة وأخيراً اضغط OK

راجع هذا الرابط من هنا

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

موضوع غير مقبول شكلاً وموضوعاً راجع التوجيهات بارك الله فيك

وضح شكل النتائج المتوقعة من عملية الترحيل .. إلى أين تريد الترحيل .. بالصور المرفقة في المشاركة الأولى بدا لي أنك تريد الترحيل إلى ورقة 2 وبالإطلاع على الفورم ومعرفة مكوناته تأكد لي ذلك ..سبحان الله عموماً ورقة4 بهذا الشكل مبهمة وغير واضحة على الإطلاق يرجى تحديد كل عملية ترحيل إلى أي خلية؟

ماذا بعد لكن ؟؟ ربما يكون هناك خطأ ... ربما يكون الكود لم يطبق بشكل جيد ... ننتظر بعد ولكن .. ويرجى إرفاق شكل النتائج المتوقعة حتى لا يطول الموضوع بدون داعي

إليك الطلب الاول وهو ترحيل البيانات من الفورم إلى ورقة2 قمت بتغيير مسميات مربعات النصوص ليناسب عمل الكود ... توفيراً للوقت Private Sub UserForm_Initialize() Dim Cell As Range For Each Cell In ورقة2.Range("C6:J6") ComboBox1.AddItem Cell.Value Next Cell End Sub Private Sub CommandButton1_Click() Dim I As Long Dim Found If ComboBox1.Value = "" Then MsgBox "لابد من اختيار الفصل الدراسي", 64: Exit Sub Found = Application.Match(ComboBox1.Value, ورقة2.Rows(6), 0) If IsNumeric(Found) Then With ورقة2 .Cells(3, "D") = Val(TextBox1) .Cells(3, "F") = Val(TextBox2) .Cells(3, "I") = Val(TextBox3) .Cells(3, "K") = Val(TextBox4) For I = 7 To 18 .Cells(I, Found) = Val(Me.Controls("TextBox" & I - 2)) Next I .Cells(20, Found) = TextBox17 End With End If End Sub Marks.rar