مسح العديد من الجدوال التى لاتحتوى على بيانات

[أبو سجده]

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

لديك على سبيل المثال عدد 200 جدول ثابت وتُنقل البيانات اليها من شيت أخر

أحيانا لا يتم نقل البيانات الإ  لعدد 150 جدول فقط " حسب مقتضيات العمل "

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

أرجو الإطلاع والافادة وجزاكم الله خيرا وبارك فيكم جميعا

حذف العديد من الجدوال التى لاتحتوى على بيانات.xlsb.rar

[ياسر خليل أبو البراء]

وعليكم السلام

جرب الكود التالي

Sub Test()
'Author  : YasserKhalil
'Release : 21 - 10 - 2016
'-------------------------
    Dim Ws          As Worksheet
    Dim Lr          As Long
    Dim tempLr      As Long
    Dim i           As Long
    Dim lastRow     As Long

    Application.ScreenUpdating = False
        Set Ws = Sheets("salry")
        With Ws
            Lr = .Range("B" & Rows.Count).End(xlUp).Row
            tempLr = .Range("C" & Rows.Count).End(xlUp).Row
    
            For i = tempLr To 1 Step -1
                If Len(.Cells(i, 3)) <> 0 Then
                    If Not .Cells(i, 3).HasFormula Then
                        lastRow = i
                        Exit For
                    End If
                End If
            Next i
            
            For i = lastRow To Lr
                If .Cells(i, 3).HasFormula Then lastRow = .Cells(i, 3).Row + 5: Exit For
            Next i
            
            .Rows(lastRow & ":" & Lr).EntireRow.Delete
        End With
    Application.ScreenUpdating = True
End Sub

 

[أبو سجده]

أخى وحبيبى ابو البراء

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

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

مع تنفيذ الكود يتم مسح الصف الخامس

المطلوب بعد إذنك اضافة شرط أخر

الا وهو فى حالة لو عدد الصفوف المُرحلة من الورقة data الى الورقة salry أقل من 20 صف يتم مسح باقى الارقام المسلسلة

فيما عدا ذلك فالامور تسرى على مايرام ***   برجاء الاطلاع على المرفق التالى

بارك الله فيكم ***** وجزاكم الله خيرا

حذف العديد من الجدوال التى لاتحتوى على بيانات.xlsb.rar

[أبو سجده]

للرفع

[أبو سجده]

أخى العزيز الاستاذ // ياسر ابو البراء

تم تحقيق الطلب الاول بتغيير هذا السطر

وبقى اضافة الشرط المطلوب

تقبل وافر تقديرى واحترامى

                If .Cells(i, 3).HasFormula Then lastRow = .Cells(i, 3).Row + 6: Exit For

 

[ياسر خليل أبو البراء]

أعتذر أخي العزيز أبو عبد الرحمن عن التأخر في الرد فقد كنت مشغولاً في أمور خاصة ولم أستطع التواصل معك

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

[أبو سجده]

ليس هناك داعى للإعتذار أخى وحبيبى ابو البراء

العكس تماما أنا من يجب أن يعتذر لاننى أعرف جيدا مشغولياتك أعانك الله تعالى عليها

نعم الكود لبى الطلب تماما وتم تعديل السطر المشار اليه

بدون صور **** لديك العمود A الخاص بالترقيم  بورقة SALRY  الترقيم هنا ثابت بثبات الجدوال

ويتلخص الشرط فى حالة لو عدد الصفوف المُرحلة من الورقة data الى الورقة salry أقل من 20 صف يتم مسح باقى الارقام المسلسلة

 

 والله مشكلة مش عارف اكمل المشاركة

ليس هناك إتاحة لتعديل أية مشاركات

يجب أن أختتم مشاركتى بجزاكم الله خيرا

فجزاكم الله خيرا وبارك فيكم

 

[ياسر خليل أبو البراء]

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

Sub Test()
'Author  : YasserKhalil
'Release : 22 - 10 - 2016
'-------------------------
    Dim Ws          As Worksheet
    Dim Lr          As Long
    Dim tempLr      As Long
    Dim i           As Long
    Dim lastRow     As Long
    Application.ScreenUpdating = False
        Set Ws = Sheets("salry")
        With Ws
            Lr = .Range("B" & Rows.Count).End(xlUp).Row
            tempLr = .Range("C" & Rows.Count).End(xlUp).Row
    
            For i = tempLr To 1 Step -1
                If Len(.Cells(i, 3)) <> 0 Then
                    If Not .Cells(i, 3).HasFormula Then
                        lastRow = i
                        Exit For
                    End If
                End If
            Next i
            For i = lastRow To Lr
                If .Cells(i, 3).HasFormula Then lastRow = .Cells(i, 3).Row + 6: Exit For
            Next i
            .Rows(lastRow & ":" & Lr).EntireRow.Delete
            
            If Application.WorksheetFunction.Count(Sheets("data").Columns(1)) < 20 Then
                Lr = .Cells(Rows.Count, 1).End(xlUp).Row
                .Range("A" & Application.WorksheetFunction.Count(Sheets("data").Columns(1)) + 8 & ":A" & Lr).ClearContents
            End If
        End With
    Application.ScreenUpdating = True
End Sub

 

[أبو سجده]

أخى الحبيب ابو البراء

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

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

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

أما المشكلة من بداية الجدول الثانى وحتى نهاية الجدوال

وخاصىة عند نقل أكثر من 20 بيان فعلى سبيل المثال مطلوب نقل 65 بيان  إذن لدينا هنا أربعة جدوال ثلاثة منهم كاملة

أما الرابع فيحتوى على 5 بيانات فقط

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

جزاكم الله خيرا وبارك فيكم

[ياسر خليل أبو البراء]

وعليكم السلام أخي أبو عبد الرحمن

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

هل الفكرة مقبولة أم أن لديك تصور آخر؟

[أبو سجده]

1 ساعه مضت, ياسر خليل أبو البراء said:

في أي عمود آخر مصاف له 1

أخى ابو البراء

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

هل تقصد إضافة عمود مساعد ؟؟

 إن كان الامر كذلك فأرى انه سيكون له الاثر السلبى على باقى اوراق العمل

اما عن التصور فليس لدىُ أية تصوارت أخرى بخصوص هذا الشأن

بارك الله فيكم وجزاكم الله خيرا

[أبو سجده]

للرفع