حسونة حسين

الكود مصنوع لكي تكون الثانيه اسمها List2 كما في هذا السطر ان اردت تغييرها لابد من تغييرها في هذا السطر X = Application.Match("List2", Sheet2.Range("A2:A" & LR), 0) + 1 الاولي اكتب اسمها كما تريد ليس لها أي علاقه في الكود

الحمد لله الذي بنعمته تتم الصالحات

تفضل اخي Option Explicit Sub Test() Dim WSData As Worksheet, WSResult As Worksheet, Arr, Ar1, Ar2 Dim I As Long, J As Long, P As Long Application.ScreenUpdating = False Application.EnableEvents = False Set WSData = Worksheets("Sheet1") Set WSResult = Worksheets("Sheet2") Arr = WSData.Range("C10:AB" & WSData.Cells(Rows.Count, 3).End(xlUp).Row).Value ReDim temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2) - 2) Ar1 = Array("سكر", "أرز", "بطاطس", "عنب") Ar2 = Array("زيادة", "ناقص", "بكثرة", "محتاج") Dim x For I = 1 To UBound(Arr, 1) P = P + 1 For J = 1 To UBound(Arr, 2) - 2 If J < 13 Then temp(P, J) = Arr(I, J) ElseIf J > 22 Then temp(P, J) = Arr(I, J + 2) Else x = Application.Match(Arr(I, J + 1), Ar1, 0) If Not IsError(x) Then temp(P, J) = Ar2(x - 1) temp(P, J + 1) = Arr(I, J + 1) Else temp(P, J) = "مخزن" temp(P, J + 1) = Arr(I, J + 1) End If J = J + 1 End If Next J Next I If P > 0 Then WSResult.Range("C10").Resize(P, UBound(temp, 2)).Value = temp Application.EnableEvents = True Application.ScreenUpdating = True End Sub

وعليكم السلام ورحمه الله وبركاته تفضل هذا التعديل CommandButton1_Click من اجل LastRow1 CommandButton2_Click من اجل LastRow2 Private Sub CommandButton1_Click() Dim LR As Long, X If TextBox1.Value <> "" Then LR = Sheet2.Range("a" & Rows.Count).End(xlUp).Row X = Application.Match("List2", Sheet2.Range("A2:A" & LR), 0) + 1 LR = WorksheetFunction.CountA(Sheet2.Range("A1:A" & X)) If LR = X Then Sheet2.Rows(X).Resize(1).EntireRow.Insert ' Resize(1) عندما تمتلئ القائمه الاولي يضيف العدد بين الاقواس Sheet2.Range("a" & LR).Value = TextBox1.Value TextBox1.Value = "" Else MsgBox ("من فضلك تأكد من ادخال البيانات") End If TextBox1.SetFocus End Sub Private Sub CommandButton2_Click() Dim LR As Long If TextBox1.Value <> "" Then 'And TextBox3.Value <> "" And TextBox4.Value <> "" Then LR = Sheet2.Range("A" & Rows.Count).End(xlUp).Row Sheet2.Range("a" & LR + 1).Value = TextBox1.Value TextBox1.Value = "" Else MsgBox ("من فضلك تأكد من ادخال البيانات") End If End Sub

السلام عليكم ورحمه الله وبركاته وبها نبدأ عدل f2 الى TextBox1 Private Sub TextBox1_Change() ActiveSheet.Unprotect "2212" Application.ScreenUpdating = False ActiveSheet.ListObjects("data").Range.AutoFilter Field:=7, Criteria1:="*" & TextBox1 & "*", Operator:=xlFilterValues Application.ScreenUpdating = True ActiveSheet.Protect "2212" End Sub واجعل Linkedcell فارغه

رجاء كل طلب في موضوع مستقل تفضل Option Explicit Sub Test() Dim WSData As Worksheet, WSResult As Worksheet, Arr, Ar1, Ar2 Dim I As Long, J As Long, P As Long Application.ScreenUpdating = False Application.EnableEvents = False Set WSData = Worksheets("Sheet1") Set WSResult = Worksheets("Sheet2") Arr = WSData.Range("C10:Z" & WSData.Cells(Rows.Count, 3).End(xlUp).Row).Value ReDim temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) Ar1 = Array("سكر", "أرز", "بطاطس", "عنب") Ar2 = Array("زيادة", "ناقص", "بكثرة", "محتاج") Dim x For I = 1 To UBound(Arr, 1) P = P + 1 For J = 1 To UBound(Arr, 2) If J < 13 Or J > 22 Then temp(P, J) = Arr(I, J) Else x = Application.Match(Arr(I, J + 1), Ar1, 0) If Not IsError(x) Then temp(P, J) = Ar2(x - 1) temp(P, J + 1) = Arr(I, J + 1) Else temp(P, J) = "مخزن" temp(P, J + 1) = Arr(I, J + 1) End If J = J + 1 End If Next J Next I If P > 0 Then WSResult.Range("C10").Resize(P, UBound(temp, 2)).Value = temp Application.EnableEvents = True Application.ScreenUpdating = True End Sub

استاذ @يوسف عطا انظر علي هذه الصورة الصف رقم 24 طالب بنين - منقول - ونتيجه الطالب ( له دور ثاني فى : /انجليزى//////المجموع///////) وفي عامود معيار الترحيل مكتوب ناجح هل هذا صحيح ام ماذا

تفضل A5.xlsx

وعليكم السلام ورحمه الله وبركاته استبدل كودك بهذا الكود ولا تحمل هم المعادلات فتم الاستغناء عنها في الكود مباشره Option Explicit Sub Test() Dim WSData As Worksheet, WSResult As Worksheet, Arr, Ar1, Ar2 Dim I As Long, J As Long, P As Long Application.ScreenUpdating = False Application.EnableEvents = False Set WSData = Worksheets("Sheet1") Set WSResult = Worksheets("Sheet2") Arr = WSData.Range("C10:X" & WSData.Cells(Rows.Count, 3).End(xlUp).Row).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) Ar1 = Array("سكر", "أرز", "بطاطس", "عنب") Ar2 = Array("زيادة", "ناقص", "بكثرة", "محتاج") Dim x For I = 1 To UBound(Arr, 1) P = P + 1 For J = 1 To UBound(Arr, 2) If J < 13 Then Temp(P, J) = Arr(I, J) Else x = Application.Match(Arr(I, J + 1), Ar1, 0) If Not IsError(x) Then Temp(P, J) = Ar2(x - 1) Temp(P, J + 1) = Arr(I, J + 1) Else Temp(P, J) = "مخزن" Temp(P, J + 1) = Arr(I, J + 1) End If J = J + 1 End If Next J Next I If P > 0 Then WSResult.Range("C10").Resize(P, UBound(Temp, 2)).Value = Temp Application.EnableEvents = True Application.ScreenUpdating = True End Sub

جرب هذه المعادله انسخها كما هي وليس كتابه =SUBSTITUTE(A2," ","")

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

اخي الفاضل ابو يوسف تقريبا ألاخ السائل قد نسخ المعادله التي تمت كتابتها كما هي بدون اي تغيير =NoToTxt(الرقم;العملة;أجزاء العملة) ولم يعدلها =NoToTxt(A1;"جنيه";"قرش")

وعليكم السلام ورحمة الله وبركاته هناك طريقتين طريقه السحب : افتح الملفين ثم من صفحه الفيجوال هيكون موجود الملفين اسحب الفورم بالماوس اللى الملف الجديد طريقه التصدير : افتح الملف الذي به الفورم ثم من صفحه الفيجوال اضغط علي الفورم المراد نقله ثم اعمل export ثم افتح الملف الذب تريد نقل الفورم به ثم من صفحه الفيجوال اعمل insert واختار الفورم الذي تم تصديره

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

اخى الكريم أين وضعت هذا الكود ضع الكود كاملا او ارفق ملف

وعليكم السلام ورحمه الله وبركاته امسح الكود الذي في الموضوع من حدث الشيت وضع هذا الكود في حدث الصفحه ثم اضغط على اي خليه ضغطتين وسوف تفتح الفورم عادي بدون مشاكل Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) kh_Show_UFormChang1.Show End Sub

وعليكم السلام ورحمة الله وبركاته يرجي رفع ملفك الذي به المشكله

سبب المشكله نسخه الاوفيس عندك ٦٤ بت يمكنك الاستفاده من هذا الموقع For code to run in 64-bit versions of Microsoft Office, all Declare statements must include the PtrSafe keyword, and all data types in the Declare statement (parameters and return values) that need to store 64-bit quantities must be updated to use LongLong for 64-bit integrals or LongPtr for pointers and handles. ودى الترجمه لتشغيل التعليمات البرمجية في إصدارات 64 بت من Microsoft Office ، يجب أن تتضمن جميع عبارات Declare الكلمة الأساسية PtrSafe ، ويجب تحديث جميع أنواع البيانات في بيان Declare (المعلمات وقيم الإرجاع) التي تحتاج إلى تخزين كميات 64 بت لاستخدام LongLong لتكاملات 64 بت أو LongPtr للمؤشرات والمقابض.

السلام عليكم ورحمة الله وبركاته وبها نبدأ مرحبا بك اخى سعيد على @2015 بين اخوانك يرجي رفع ملف ليري الأخوة المشكله

تفضل اخي كود بسيط Option Explicit Sub Test() Dim cell As Range For Each cell In Range("C2:C" & Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible) cell.Formula = "=" & "B" & cell.Row & "-20" Next cell End Sub

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

وعليكم السلام ورحمة الله وبركاته قبل كلمه Function ضع Ptrsafe

وعليكم السلام ورحمة الله وبركاته الشكر لله اخى @Amr Ashraf الحمد لله الذي بنعمته تتم الصالحات

كيف اضبط Label مع رؤوس الاعمدة فى الليس بوكس

رؤوس الاعمده ابسط حاجه ممكن تعملها ب labels فوق الليست بوكس