عبدالفتاح في بي اكسيل

عذرا اخي ولكن هذه طريقة غير لائقة تماما ماذا لوكان عندك 1000 عنصر في العمود الثاني كيف سيظهر في اليوزفورم؟!!

يجب ان تكون ازرار محدودة .

ربما شخص  اخر لديه وجهة نظر افضل مني .

@M.NHAKAMI

 ولكن  لماذا  كل هذه الاسطر  وعدم تنظيم  في  ارقام  الليبل ؟!

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

على  اي حال  في  نهاية مدى كل خليه  ضع كلمة TEXT 

هذا مثال 

Label163.Caption = Sheets("دراسة فندق").Range("h6").Text 

اقتباس

ا / عبدالفتاح في بي اكسيل عندما اضغط على زرار  debug يتم اغلاق الملف

 

اعتقد انك مخطئ  ، هذا  يحدث عند الضغط على زر END

@الفارس محمد رجب

عندما تتحدث عن خطأ يجب ان تظهر  لنا في  أي  سطر  والا الصورة  لا معنى لها !

سأرى ما يمكنني فعله  اذا لم يتدخل احد  الأعضاء ولكن  حاليا مشغول .

تحياتي

لم افهم تعليقك الأخير !

هل عمل معك الملف ؟

@الفارس محمد رجب

ولكن اين الكود  الذي حاولت القيام به؟!!

بالمناسبة موضوعك ليس بالمعقد ، يمكنك البحث عن مواضيع قد تم تناولها مسبقا وتعديله بناء على احتياجاتك.

تحياتي

هذا يختلف  على  مهام  الكود ماذا  يفعل  بالضبط .

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

تحياتي

اذا كنت تقصد اظهار التقويم لاختيار التاريخ عندها يمكن استخدام اداتين  date picker او  calendar .

هذه محاولة  بعد القيام بإضافة فورم التقويم والقيام ببعض التعديلات .

قم بالنقر مرتين علي خلية التاريخ وسيظهر التقويم . 

ولكن هذا يتوقف على اصدار  الاوفيس  اشك انها تعمل مع الإصدارات قبل 2016 واذا  واجهتك مشكلة  بإظهار  رسالة بعدم وجود كائن عنده  يجب تنصيبه حتى يظهر  لك .

حاليا يعمل  معي  باستخدام  بإصدار 2019

تحياتي

مطلوب تعديل.xlsm

جرب هذه المعادلة  مع مراعاة الفاصلة على حسب اصدار الاوفيس

=IF(ISERROR(SEARCH("-";F11));1;TRIM(RIGHT(SUBSTITUTE(F11;"-";REPT(" ";100));100)))

1 ساعه مضت, عادل ابوزيد said:

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

يجدر القيام بحلقة تكرارية في هذه الحالة 

Sub delete_tools()
    Dim ws As Worksheet
    For Each ws In Worksheets
    ws.DrawingObjects.Delete
    Next ws
End Sub

عندما  تريد  المساعدة  وجب  ارفاق  الملف ووضع  البيانات قبل وكيف  تكون بعد ، وما  هو حجم بياناتك  حتى  يكون الكود بطيء ؟!!

بنظرة على كودك يوجد حلقات تكرارية كثيرة وهذا  الذي  سيسبب البطيء .

اختصر الحلقات التكرارية قدر الإمكان .

تحياتي .

ادخل  على خيارات  الوظائف  الاضافية وازل  تاشيرات الادوات  التي  لا تريدها .

جرب هذ  التعديل 

لا فائدة  من السطر  الاول  في  بداية الكود لقد  قمت  بازالته 

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

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim LastRow As Long
    Dim FilterRange As Range
    LastRow = Me.Cells(Rows.Count, "D").End(xlUp).Row
    Set FilterRange = Range("C9:U" & LastRow)
    If Me.FilterMode Then Me.ShowAllData
    If Not IsEmpty(Range("D8")) Then
        FilterRange.AutoFilter Field:=2, Criteria1:=Range("D8").Value
    ElseIf Not IsEmpty(Range("E8")) Then
        FilterRange.AutoFilter Field:=4, Criteria1:=Range("E8").Value
        
    End If

End Sub

@sabah2023

,لكن  كيف  عمل  معك  الكود  من البداية ؟!!

طلبك يكون مثل هذا بناء على مشاركتك الاولى  2023/08/23

الكود  لا يفعل ذلك !

عليك تغيير هذا  السطر من 

 .NumberFormat = "yyyy/dd/mm"

الى 

 .NumberFormat = "yyyy/mm/dd"

@AMIRBM

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

اما  ان  تظهر  كل  الاعمدة بالليست بوكس  ومن تم  عند  اختيار  الصف  من  الليست بوكس  يتم  اظهارها بالتيكست بوكس او حدف  الليست بوكس  واستخدام التيكست بوكس  بدلا من ذلك 

اقتباس

ولا تحتاج لتغيير في الكود في هذه الحالة

ولكن  في  بعض  الحالات   لا  تعمل  عندما  تكون  بياناتك  عبارة  عن  جدول  وفي  الكود  يتم  الاشارة الى  مدى عادي  لذا  اجد  من  المفيد لتجنب  المشاكل  الاشارة الى كائن الجدول .

@mohamed.youssef

ساعد نفسك قبل ان تطلب المساعدة  من الاخرين 

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

 ما  الفائدة من  اظهار الرؤوس ، لما لا  تقوم بعمل ليبل لكل  راس  وتنتهي  المشكلة  كما  قمت  بتصميم الفورم ؟

اذاكان  كل  اذن يحتوي على  رقم  فريد  اذن  ما  الحاجة  لاظهارة في  التيكست بوكس طالما سيظهر فقط  صف  واحد بالليست بوكس؟  اذن  البيانات واضحة  ولا حاجة لذلك ! 

@2saad

هل ممكن ان تقول  لي المتغير  i فيما  يستخدم بناء على كودك؟!!!

Private Sub CommandButton2_Click()
Dim add As Integer
i = Application.WorksheetFunction.CountA(Sheet54.Range("c:c"))
add = Sheet54.Range("c1000").End(xlUp).row + 1
Sheet54.Cells(add, 3).Value = Me.TextBox1.Value
Sheet54.Cells(add, 4).Value = Me.TextBox2.Value
Sheet54.Cells(add, 5).Value = Me.TextBox3.Value
Sheet54.Cells(add, 6).Value = Me.TextBox4.Value
Sheet54.Cells(add, 7).Value = Me.TextBox5.Value
Sheet54.Cells(add, 8).Value = Me.TextBox6.Value
Sheet54.Cells(add, 9).Value = Me.TextBox7.Value
Sheet54.Cells(add, 10).Value = Me.TextBox8.Value
Sheet54.Cells(add, 11).Value = Me.TextBox9.Value
Sheet54.Cells(add, 12).Value = Me.TextBox10.Value
Me.TextBox1.Value = ""
Me.TextBox2.Value = ""
Me.TextBox3.Value = ""
Me.TextBox4.Value = ""
Me.TextBox5.Value = ""
Me.TextBox6.Value = ""
Me.TextBox7.Value = ""
Me.TextBox8.Value = ""
Me.TextBox9.Value = ""
Me.TextBox10.Value = ""
MsgBox "تم حفظ البيانات بنجاح يا عم سعد", vbInformation, "تنبيه يا عم سعد"

End Sub

جرب  هذا  التغيير  ولكن  قبل  كل  شيء اتبع  الخطوات بعناية 

1- احدف  اي  صف  فارغ في  الجدول ( لا تجعل الجدول يحتوي على صفوف فارغة) 

2- لا داعي  للتيكست بوكس  الخاص  بالتسلسل  لانه  الكود  سيقوم بادراج صف ويقوم بترقيمها اتوماتيكيا  حينها  سيصبح عند 9 تيكست بوكس وليس 10 كما  في الكود 

3- تم  التعديل  باضافة اجراءات خاصة بكائن الجدول 

هذه محاولة قد تفيدك

Private Sub CommandButton2_Click()
Dim tbl As ListObject
Dim LastRow As Long

Set tbl = Sheet54.ListObjects("Table14")
LastRow = tbl.Range.Rows.Count 

With Sheet54
    tbl.Range(LastRow, "B").Offset(1) = TextBox1.Value
    tbl.Range(LastRow, "C").Offset(1) = TextBox2.Value
    tbl.Range(LastRow, "D").Offset(1) = TextBox3.Value
    tbl.Range(LastRow, "E").Offset(1) = TextBox4.Value
    tbl.Range(LastRow, "F").Offset(1) = TextBox5.Value
    tbl.Range(LastRow, "G").Offset(1) = TextBox6.Value
    tbl.Range(LastRow, "H").Offset(1) = TextBox7.Value
    tbl.Range(LastRow, "I").Offset(1) = TextBox8.Value
    tbl.Range(LastRow, "J").Offset(1) = TextBox9.Value
End With

MsgBox "تم حفظ البيانات بنجاح يا عم سعد", vbInformation, "تنبيه يا عم سعد"
Me.TextBox1.Value = ""
Me.TextBox2.Value = ""
Me.TextBox3.Value = ""
Me.TextBox4.Value = ""
Me.TextBox5.Value = ""
Me.TextBox6.Value = ""
Me.TextBox7.Value = ""
Me.TextBox8.Value = ""
Me.TextBox9.Value = ""

End Sub

@محمود الطحاوي

مجرد  فضول   ان  لم  افهم  ماذا  تعني  الصورة  المدرجة  وهل جربت  اقتراحي  ام  لم  تعرف  التعديل . 

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

لا احد  يعمل  على  تخمين  لاضاعة الوقت .

اذا  اردت  بالكود  وجب  عليك  ارفاق ملف xlsm

بناء  على  مرفقك وقلة  التفاصيل  لا تتوقع  احد  ان  يجيبك .

حتى  تجد  تفاعل اكثر  ضع  النتائج  المتوقعة  في  الشيتات المستهدفة .

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

هذا مجرد  تخمين  واذاكان  هناك  شيء  نسيته  او  شرحته  بطريقة  خاطئة وجب  عليك تطويع  الكود بنفسك .

Sub CopyData()
    Application.ScreenUpdating = False
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = ThisWorkbook.Sheets("بيانات")
    Set ws2 = ThisWorkbook.Sheets("سجل قيد")
    Set ws3 = ThisWorkbook.Sheets("سجل حالات")
    With ws1
        .Range("A1").AutoFilter 10, ""
        .AutoFilter.Range.Copy
        With ws2
            .Range("A1").PasteSpecial xlPasteValues
        End With
        .Range("A1").AutoFilter
    End With
    With ws1
        .Range("A1").AutoFilter 10, "<>"
        .AutoFilter.Range.Copy
        With ws3
            .Range("A1").PasteSpecial xlPasteValues
        End With
        .Range("A1").AutoFilter
    End With
    Application.ScreenUpdating = True
    End Sub

Book1.xlsm

مجرد تخمين 

Sub Button1_Click()
 Dim i As Long
 For i = Sheet1.Cells(Rows.Count, 3).End(xlUp).Row To 1 Step -1
 If Sheet1.Cells(i, 3) = "ناجح" Or Sheet1.Cells(i, 3) = "راسب" Then
 Sheet1.Range("a" & i & ":c" & i).Copy Sheet3.Cells(Rows.Count, 1).End(xlUp).Offset(1)
 End If
 Next
End Sub

@شبل ليث

مجرد ملاحظة  

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

تحياتي 

مرحبا 

تريد رد ولا تريد ارفاق  ملف 😱😱

ستتم الاجابة ايضا  بلا  ملف  ومن واقع تخمين فقط 

يمكنك ازالة اخر سطر اذا كنت  لا تريد مسح  التيكست بوكس

Private Sub TextBox1_Change()
If Left(TextBox1.Text, 1) = "K" Then
   MsgBox "هذا  الحرف موجود بالفعل"
End If
TextBox1.Text = ""
End Sub

مجرد تخمين 

خطا  في  كتابة  الصيغة 

RM2.Cells(Lf, "G").Value = RM3.Cells(Lsrch, Sr1).Value
RM2.Cells(Lf, "D").Value = RM3.Cells(Lsrch, Sr2).Value

يجب ان تكون 

RM2.Cells(Lf, 7).Value = RM3.Cells(Lsrch, Sr1).Value
RM2.Cells(Lf, 4).Value = RM3.Cells(Lsrch, Sr2).Value