اذهب الي المحتوي
أوفيسنا

حسونة حسين

أوفيسنا
  • Posts

    1092
  • تاريخ الانضمام

  • تاريخ اخر زياره

  • Days Won

    32

كل منشورات العضو حسونة حسين

  1. السلام عليكم ورحمه الله وبركاته وبها نبدأ تفضل ضع هذا الكود في حدث الشيت المطلوب Private Sub Worksheet_Change(ByVal Target As Range) Dim X As Range Application.EnableEvents = False For Each X In Target If X.Row > 3 Then If X.Column = 2 Then If X.Value = "ok" Then X.Offset(0, -1).Value = Date ElseIf X.Column = 3 Then If X.Offset(0, -1).Value = "ok" Then X.Offset(0, 1).Value = X End If End If Next X Application.EnableEvents = True End Sub
  2. السلام عليكم ورحمه الله وبركاته تفضل أفريل.xlsx
  3. وعليكم السلام ورحمة الله وبركاته اخي @الأستاذ سيد الأكرت الملفات المرفقه ليست ملفات اكسيل او انها تم تشفيرها والله اعلم اخي @aaaaaauto @محمد الشابورى الملف الذي ارفقته باسم test.xlsx في هذه المشاركه ليس به مشكله وهو ملف سليم فقط قم بتغيير امتداد الملف الي xlsm
  4. وعليكم السلام ورحمة الله وبركاته عدل xls إلى xlsx في هذا السطر
  5. وجزاكم مثله اخى الحمد لله الذي بنعمته تتم الصالحات
  6. الكود مصنوع لكي تكون الثانيه اسمها List2 كما في هذا السطر ان اردت تغييرها لابد من تغييرها في هذا السطر X = Application.Match("List2", Sheet2.Range("A2:A" & LR), 0) + 1 الاولي اكتب اسمها كما تريد ليس لها أي علاقه في الكود
  7. الحمد لله الذي بنعمته تتم الصالحات
  8. تفضل اخي 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
  9. وعليكم السلام ورحمه الله وبركاته تفضل هذا التعديل 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
  10. السلام عليكم ورحمه الله وبركاته وبها نبدأ عدل 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 فارغه
  11. رجاء كل طلب في موضوع مستقل تفضل 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
  12. استاذ @يوسف عطا انظر علي هذه الصورة الصف رقم 24 طالب بنين - منقول - ونتيجه الطالب ( له دور ثاني فى : /انجليزى//////المجموع///////) وفي عامود معيار الترحيل مكتوب ناجح هل هذا صحيح ام ماذا
  13. وعليكم السلام ورحمه الله وبركاته استبدل كودك بهذا الكود ولا تحمل هم المعادلات فتم الاستغناء عنها في الكود مباشره 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
  14. جرب هذه المعادله انسخها كما هي وليس كتابه =SUBSTITUTE(A2," ","")
  15. وجزاكم مثله استاذ @يوسف عطا امين يارب العالمين وإياكم والحمد لله الذي بنعمته تتم الصالحات
  16. اخي الفاضل ابو يوسف تقريبا ألاخ السائل قد نسخ المعادله التي تمت كتابتها كما هي بدون اي تغيير =NoToTxt(الرقم;العملة;أجزاء العملة) ولم يعدلها =NoToTxt(A1;"جنيه";"قرش")
  17. وعليكم السلام ورحمة الله وبركاته هناك طريقتين طريقه السحب : افتح الملفين ثم من صفحه الفيجوال هيكون موجود الملفين اسحب الفورم بالماوس اللى الملف الجديد طريقه التصدير : افتح الملف الذي به الفورم ثم من صفحه الفيجوال اضغط علي الفورم المراد نقله ثم اعمل export ثم افتح الملف الذب تريد نقل الفورم به ثم من صفحه الفيجوال اعمل insert واختار الفورم الذي تم تصديره
  18. وعليكم السلام ورحمة الله وبركاته وعلى فكره ده اول رد للسلام الذي بدأه اخى ابو خليل وكمان الملف الأول يكون هديه مجانيه اما الملف الثاني له وضع آخر
  19. اخى الكريم أين وضعت هذا الكود ضع الكود كاملا او ارفق ملف
×
×
  • اضف...

Important Information