حذف سطر بكبسة زر

[أب مارية]

السلام غليكم

كيف يمكن ادراج كود لزر يتم من خلاله حذف السطور داخل جدول

 

[حمادة باشا]

الأخ الكريم/  foular

السلام عليكم ورحمة الله وبركاته

يمكنك الإستعانة بالكود في المرفق

تقبل تحياتي

 

Book1-Delete Row.rar

[طلعت محمد حسن]

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

سؤالي لو اردنا حذف البيانات من داخل فورم كيف يكون الكود

وشكرا

[أب مارية]

مشكور اخي طلعت على العمل

لو تكرمت بشرح الكود للافادة

[حمادة عمر]

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

سؤالي لو اردنا حذف البيانات من داخل فورم كيف يكون الكود

وشكرا

 

السلام عليكم

الاخ الكريم / طلعت محمد حسن

بارك الله فيك

بعد اذن اخي الحبيب /  حمادة باشا ... جزاه الله خيرا

وبنفس الكود المستخدم من طرفه في مشاركتة

تم تنفيذ طلبك بوضع الكود واستخدامه عن طريق الفورم ... وايضا عن طريق الوقوف داخل اي خلية بالجدول بعد اظهار الفورم

ام ان هناك شرط في الفورم كبحث او ....

واليك المرفق

تقبلوا خالص تحياتي

 

 

Book1-Delete Row1.rar

[أب مارية]

اخي حمادة بارك الله فيك على العمل

سؤال ثاتي 

في المرفق نريد عند حذف أي صف في الجدول الاول ادراج كود يقوم باضافة القيمة الموجودة في العمود C في الجدول الاول إلى القيمة المقابلة لها في الجدول الثاني في الورقة الثانية 

Book1-Delete Row.rar

[حمادة باشا]

أستاذنا وحبيبنا/ حمادة عمر

السلام عليكم ورحمة الله وبركاته

أسأل الله أن تكون في أحسن حال

أدخل مباشرة دون إستذان

[طلعت محمد حسن]

 

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

سؤالي لو اردنا حذف البيانات من داخل فورم كيف يكون الكود

وشكرا

 

السلام عليكم

الاخ الكريم / طلعت محمد حسن

بارك الله فيك

بعد اذن اخي الحبيب /  حمادة باشا ... جزاه الله خيرا

وبنفس الكود المستخدم من طرفه في مشاركتة

تم تنفيذ طلبك بوضع الكود واستخدامه عن طريق الفورم ... وايضا عن طريق الوقوف داخل اي خلية بالجدول بعد اظهار الفورم

ام ان هناك شرط في الفورم كبحث او ....

واليك المرفق

تقبلوا خالص تحياتي

 

 

Book1-Delete Row1.rar

 

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

[أب مارية]

اخي حمادة بارك الله فيك على العمل

سؤال ثاتي 

في المرفق نريد عند حذف أي صف في الجدول الاول ادراج كود يقوم باضافة القيمة الموجودة في العمود C في الجدول الاول إلى القيمة المقابلة لها في الجدول الثاني في الورقة الثانية 

للرفع

[أبو حنــــين]

السلام عليكم

بعد اذن لخي  حمادة استعمل هذا الكود بدل الكود السابق

Private Sub CommandButton1_Click()

Dim ActiveRow As Long, LastSheet2 As Long, ActivShet As Long
Dim DeleteValue, ActiveValue
'----------------------------------------------------------------------------------------------
    LastSheet2 = Sheets("Sheet2").Cells(Rows.Count, 2).End(xlUp).Row
    ActivShet = Sheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row
'----------------------------------------------------------------------------------------------
If Application.Intersect(Range("A2:C" & ActivShet), ActiveCell) Is Nothing Then GoTo 1
'----------------------------------------------------------------------------------------------
    ActiveRow = ActiveCell.Row
    If MsgBox("هل تريد حذف هذا السجل من قاعدة البيانات", vbCritical + _
    vbMsgBoxRight + vbYesNo, "حذف") = vbNo Then Exit Sub
'----------------------------------------------------------------------------------------------
For Each DeleteValue In Sheets("Sheet2").Range("B2:B" & LastSheet2)
For Each ActiveValue In Sheets("Sheet1").Range("B2:B" & ActivShet)
If DeleteValue.Value = ActiveValue.Value Then DeleteValue.Offset(0, 1).Value = _
    Val(DeleteValue.Offset(0, 1)) + Val(ActiveValue.Offset(0, 1))
    Next: Next
'----------------------------------------------------------------------------------------------
Sheets("Sheet1").Range(Cells(ActiveRow, 1), Cells(ActiveRow, 3)).Delete
MsgBox "تم حذف السجل و اضافة قيمته الى قاعدة البيانات", vbInformation + vbMsgBoxRight, "حذف"
Sheets("Sheet1").Range("A2") = 1: Sheets("Sheet1").Range("A3") = 2
Sheets("Sheet1").Range("A2:A3").AutoFill Destination:=Range("A2:A" & ActivShet - 1), Type:=xlFillDefault
Exit Sub
1
MsgBox "الخلية الحالية خارج نطاق البيانات", vbExclamation, "خطأ"


End Sub

تم تعديل نوفمبر 22, 2013 بواسطه أبو حنين

[أب مارية]

تسلم أخي ابو حنين على العمل

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

[أبو حنــــين]

السلام عليكم

Private Sub CommandButton1_Click()

Dim LRR As Long, LR As Long
Dim Bb
'----------------------------------------------------------------------------------------------

LRR = Sheets("Sheet2").Cells(Rows.Count, 2).End(xlUp).Row
LR = Cells(Rows.Count, "a").End(xlUp).Row

'----------------------------------------------------------------------------------------------

If Application.Intersect(Range("A2:C" & LR), ActiveCell) Is Nothing Then GoTo 1

'----------------------------------------------------------------------------------------------
    
    ActiveRow = ActiveCell.Row
    If MsgBox("هل تريد حذف هذا السجل من قاعدة البيانات", vbCritical + _
    vbMsgBoxRight + vbYesNo, "حذف") = vbNo Then Exit Sub

'----------------------------------------------------------------------------------------------

For Each Bb In Sheets("Sheet2").Range("B2:B" & LRR)
If Bb = Cells(ActiveCell.Row, 2) Then Bb.Offset(0, 1) = Val(Bb.Offset(0, 1)) + Val(Cells(ActiveCell.Row, 2).Offset(0, 1))
Next

'----------------------------------------------------------------------------------------------

Sheets("Sheet1").Range(Cells(ActiveRow, 1), Cells(ActiveRow, 3)).Delete
MsgBox "تم حذف السجل و تم اضافة قيمته الى قاعدة البانات ", vbInformation + vbMsgBoxRight, "تم الحذف"
Sheets("Sheet1").Range("A2") = 1: Sheets("Sheet1").Range("A3") = 2
Sheets("Sheet1").Range("A2:A3").AutoFill Destination:=Range("A2:A" & LR - 1), Type:=xlFillDefault
Exit Sub

'----------------------------------------------------------------------------------------------

1
MsgBox "الخلية الحالية خارج نطاق الجدول .", vbExclamation, "خطأ"
'----------------------------------------------------------------------------------------------


End Sub

[أب مارية]

مشكور أخي أبو حنين

أسأل الله أن أن ينور دربك ويجعلك ذخرا للاسلام والمسلمين

[أب مارية]

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

وأردنا هنا عند حذف عملية في صفحة الـVents فماهو الكود اللازم  تطبيقه بحيث يقوم باضافة عدد الوحدات المحذوفة في صفحة Vents إلى عدد الوحدات في صفحة Stocks

أي أنه يقتصر في هذه الحالة على ارجاع عدد الوحدات دون المجموع 

[أب مارية]

للرفع

[أب مارية]

للرفع

[أب مارية]

هل المطلوب يحتاج إلى معادلات معقدة أم ماذا؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟ظظ

[أب مارية]

لقد قمت بالتعديل على كود الاخ ابو حنين وارجو التصحيح 

Dim LRR As Long, LR As Long

Dim Bb

'----------------------------------------------------------------------------------------------

 

LRR = Sheets("Sheet2").Cells(Rows.Count, 3).End(xlUp).Row

LR = Cells(Rows.Count, "a").End(xlUp).Row

 

'----------------------------------------------------------------------------------------------

 

If Application.Intersect(Range("A2:C" & LR), ActiveCell) Is Nothing Then GoTo 1

 

'----------------------------------------------------------------------------------------------

    

    ActiveRow = ActiveCell.Row

    If MsgBox("SUPPRIMER", vbCritical + _

    vbMsgBoxRight + vbYesNo, "SUP") = vbNo Then Exit Sub

 

'----------------------------------------------------------------------------------------------

 

For Each Bb In Sheets("Sheet2").Range("B2:B" & LRR)

If Bb = Cells(ActiveCell.Row, 2) Then Bb.Offset(0, 2) = Val(Bb.Offset(0, 1)) + Val(Cells(ActiveCell.Row, 2).Offset(0, 1))

Next

 

'----------------------------------------------------------------------------------------------

 

Sheets("Sheet1").Range(Cells(ActiveRow, 1), Cells(ActiveRow, 3)).Delete

MsgBox "SUPPRIMER ", vbInformation + vbMsgBoxRight, "OK"

Sheets("Sheet1").Range("A2") = 1: Sheets("Sheet1").Range("A3") = 2

Sheets("Sheet1").Range("A2:A3").AutoFill Destination:=Range("A2:A" & LR - 1), Type:=xlFillDefault

Exit Sub

 

'----------------------------------------------------------------------------------------------

 

1

MsgBox "?????? ??????? ???? ???? ?????? .", vbExclamation, "???"

'----------------------------------------------------------------------------------------------

[أب مارية]

بعد تطبيق بعض التعديلات بقي هناك مشكل فأرجو المساعدة

 

Book1-Delete Row.rar

[أب مارية]

ارجو المساعدة مشكل في الجدول بعد حذف اي سطر بسبب خطا في الكود 

Book1-Delete Row.rar

[أبو حنــــين]

استعمل هذا الكود

Private Sub CommandButton1_Click()
Dim LRR As Long, LR As Long
Dim Bb
LRR = Sheets("Sheet2").Cells(Rows.Count, 3).End(xlUp).Row
LR = Cells(Rows.Count, "A").End(xlUp).Row
If Application.Intersect(Range("A2:E" & LR), ActiveCell) Is Nothing Then GoTo 1
    ActiveRow = ActiveCell.Row
    If MsgBox("هل تريد حذف السجل", vbCritical + _
    vbMsgBoxRight + vbYesNo, "حذف") = vbNo Then Exit Sub
For Each Bb In Sheets("Sheet2").Range("B2:B" & LRR)
If Bb = Cells(ActiveCell.Row, 2) Then Bb.Offset(0, 2) = Val(Bb.Offset(0, 2)) + Val(Cells(ActiveCell.Row, 3).Offset(0, 1))
Next
Sheets("Sheet1").Range(Cells(ActiveRow, 1), Cells(ActiveRow, 5)).Delete
MsgBox "تم حذف السجل", vbInformation + vbMsgBoxRight, "تأكيد"
Sheets("Sheet1").Range("A2") = 1: Sheets("Sheet1").Range("A3") = 2
Sheets("Sheet1").Range("A2:A3").AutoFill Destination:=Range("A2:A" & LR - 1), Type:=xlFillDefault
Sheets("Sheet1").Range("A2:A3").Offset(0, 4).AutoFill Destination:=Range("A2:A" & LR - 1).Offset(0, 4), Type:=xlFillDefault
Exit Sub
1
MsgBox "الخلية الحالية خارج النطاق", vbExclamation, "خطأ"
End Sub

[أب مارية]

شكرا جزيلا أخي أبو حنين

 

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

[أبو حنــــين]

آمين يا رب العالمين  لنا و لكم ان شاء الله

سبحان الله و لا حول و لاقوة الا بالله

و الله لم اسمع دعاءا مثل هذا

جزاك الله الفردوس الاعلى  و حفظك و رعاك

وتقبل منكم و منا صالح الاعمال

[أب مارية]

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

Book1-Delete Row.rar

[أبو حنــــين]

السلام عليكم

استعمل هذا التعديل

Private Sub CommandButton1_Click()
Dim LRR As Long, LR As Long
Dim Bb
LRR = Sheets("Stocks").Cells(Rows.Count, 3).End(xlUp).Row
LR = Cells(Rows.Count, "A").End(xlUp).Row
If Application.Intersect(Range("A8:I" & LR), ActiveCell) Is Nothing Then GoTo 1
    ActiveRow = ActiveCell.Row
    If MsgBox("هل تريد حذف السجل", vbCritical + _
    vbMsgBoxRight + vbYesNo, "Íحذف") = vbNo Then Exit Sub
    
For Each Bb In Sheets("Stocks").Range("B12:B" & LRR)
If Bb = Cells(ActiveCell.Row, 2) Then Bb.Offset(0, 2) = Val(Bb.Offset(0, 2)) + Val(Cells(ActiveCell.Row, 3).Offset(0, 1))
Next
Sheets("Vents").Range(Cells(ActiveRow, 1), Cells(ActiveRow, 9)).Delete
MsgBox "تم حذف السجل", vbInformation + vbMsgBoxRight, "تأكيد"
Sheets("Vents").Range("A8") = 1: Sheets("Vents").Range("A9") = 2
Sheets("Vents").Range("A8:A9").AutoFill Destination:=Range("A8:A" & LR - 1), Type:=xlFillDefault

Sheets("Vents").Range("A8:A9").Offset(0, 6).AutoFill Destination:=Range("A8:A" & LR - 1).Offset(0, 6), Type:=xlFillDefault
Sheets("Vents").Range("A8:A9").Offset(0, 7).AutoFill Destination:=Range("A8:A" & LR - 1).Offset(0, 7), Type:=xlFillDefault
Sheets("Vents").Range("A8:A9").Offset(0, 8).AutoFill Destination:=Range("A8:A" & LR - 1).Offset(0, 8), Type:=xlFillDefault

Exit Sub
1
MsgBox "الخلية الحالية خارج النطاق", vbExclamation, "خطأ"
End Sub