كيف اقوم بالغاء فراغات جدول وترتيب بياناته من دون الغاء صفوف

[atob]

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

اخواني الاعزاء هذا الطلب حيرني كثيرا

وهو كيف اقوم بترتيب جدول والغي الفراغات الموجوده به بحيث الا تتأثر الصفوف من حيث اخفاء او حذف صفوف

والملف المرفق يوضح اكثر عن طلبي

الغاء الفراغات.rar

واشكركم على تعاونكم معي

[عبدالله باقشير]

السلام عليكم

بدلا من المسح

استخدم حذف خلايا

Target.Resize(1, 4).delete xlUp

يحذف الخلايا المعينة فقط

بازاحة الخلايا السفلية الى اعلى

بدون المساس ببقية خلايا الصف

[atob]

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

[عبدالله باقشير]

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

لو بامكانك تغيير مكان الجدول الاسفل احسن

او

استخدم الفرز للجدول الاعلى

[الـعيدروس]

السلام عليكم

هذا تعديل ربما يفي بالغرض

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Target.Column = 2 Then

If Me.FilterMode Then GoTo 1

If Not Application.Intersect(Target, Range("b6:b24")) Is Nothing Then

	 Cancel = True

	 If MsgBox("هل تريد الغاء الكتاب" & vbCr & Target.Value, vbYesNo + vbMsgBoxRight) = vbYes Then

		 With Application

		 .ScreenUpdating = False

		 .EnableEvents = False

		 Target.Resize(1, 4).EntireRow.delete

		 I = 1

		 R = 6

			 Do While I < Range("B1500").End(xlUp).Row - 6

		 Cells(R, 1).Value = I

		 I = I + 1

		 R = R + 1

		 Loop

		 .EnableEvents = True

		 .ScreenUpdating = True

	 End With

		 MsgBox "تم الالغاء "

	 End If

End If

End If

1:

End Sub

وهذا تعديل بطريقة اخرى

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Target.Column = 2 Then

If Me.FilterMode Then GoTo 1

If Not Application.Intersect(Target, Range("b6:b24")) Is Nothing Then

On Error Resume Next

	 Cancel = True

	 If MsgBox("هل تريد الغاء الكتاب" & vbCr & Target.Value, vbYesNo + vbMsgBoxRight) = vbYes Then

		 With Application

		 .ScreenUpdating = False

		 .EnableEvents = False

			 B = Cells(Rows.Count, 2).End(xlUp).Row

			 Target.Resize(1, 4).ClearContents

			 Range(Cells(Target.Offset(1, 0).Row, 2), Cells(B, 5)).Cut _

			 Destination:=Range(Cells(Target.Row, 2), Cells(B, 5))

		 .EnableEvents = True

		 .ScreenUpdating = True

	 End With

		 MsgBox "تم الالغاء "

	 End If

End If

End If

1:

End Sub

وهذا تعديل بطريقة مختلفه

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Target.Column = 2 Then

    If Me.FilterMode Then GoTo 1

    If Not Application.Intersect(Target, Range("b6:b24")) Is Nothing Then

    On Error Resume Next

    Dim R As Range

    Dim B&

	    Cancel = True

	    If MsgBox("هل تريد الغاء الكتاب" & vbCr & Target.Value, vbYesNo + vbMsgBoxRight) = vbYes Then

		 With Application

		    .ScreenUpdating = False

		    .EnableEvents = False

			 B = Cells(Rows.Count, 2).End(xlUp).Row

			  Target.Resize(1, 4).ClearContents

			  For Each R In Range(Cells(Target.Offset(1, 0).Row, Target.Column), Cells(B, 5)).Areas

			   R.Cut R.Offset(-1, 0)

			  Next

		   .EnableEvents = True

		   .ScreenUpdating = True

	    End With

		   MsgBox "تم الالغاء "

	    End If

    End If

End If

1:

End Sub

تم تعديل أكتوبر 21, 2012 بواسطه عباد

[atob]

اخي عبدالله باشقير ما قد قصرت من اول فدائما تسبق الي الخير

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

بمعنى ان يبقى الجدول او النطاق (b6:e25) لا يتغير لونه او تنسيقه لانه مع الكود يتغير

على العموم الكود اكثر من رائع وما قصرت والله يوفقك دنيا واخره

[الـعيدروس]

السلام عليكم

تعديل للكود الاخير لطلبك الاخير

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Target.Column = 2 Then

			 If Me.FilterMode Then GoTo 1

				 If Not Application.Intersect(Target, Range("b6:b24")) Is Nothing Then

			 On Error Resume Next

			 Dim R As Range

			 Dim B&

				 Cancel = True

				 If MsgBox("هل تريد الغاء الكتاب" & vbCr & Target.Value, vbYesNo + vbMsgBoxRight) = vbYes Then

			 With Application

				 .ScreenUpdating = False

				 .EnableEvents = False

			 B = Cells(Rows.Count, 2).End(xlUp).Row

				 Target.Resize(1, 4).ClearContents

			 For Each R In Range(Cells(Target.Offset(1, 0).Row, Target.Column), Cells(B, 5)).Areas

				 R.Offset(-1, 0).Value = R.Value

			 Next

				 Range("B" & Cells(Rows.Count, 2).End(xlUp).Row).Resize(, 4).ClearContents

				 .EnableEvents = True

				 .ScreenUpdating = True

			 End With

		 MsgBox "تم الالغاء "

				 End If

			 End If

End If

1:

End Sub

تم تعديل أكتوبر 22, 2012 بواسطه عباد