التخلص من الفراغات بدون الحذف

[أبو عبد الله _]

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

اريد طريق للتخلص من الفراغات بدون التأثير على المدى في المعادلات

 

New Microsoft Excel Worksheet.xlsx

[أ / محمد صالح]

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

يمكنك تجربة هذا الكود

Sub MoveDataWithoutDeletingRows()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long, startRow As Long
    Set ws = ThisWorkbook.Sheets("Sheet1") ' قم بتغيير اسم الورقة حسب الحاجة
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    startRow = 1 ' يمكنك تغيير قيمة startRow حسب الحاجة
    For i = startRow To lastRow
        If Application.WorksheetFunction.CountA(ws.Range("A" & i & ":E" & i)) > 0 Then
            If i <> startRow Then
                ws.Range("A" & i & ":E" & i).Copy Destination:=ws.Range("A" & startRow & ":E" & startRow)
            End If
            startRow = startRow + 1
        End If
    Next i
    ' مسح البيانات من الصفوف الأصلية دون حذف الصفوف
    ws.Range("A" & startRow & ":E" & lastRow).ClearContents
End Sub

بالتوفيق 

[محمد هشام.]

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

بعد معاينة الملف لاحظت انك ترغب بحدف الخلايا الفارغة مع البقاء على البيانات بمكانها الاصلي مع مراعات عدم التاثير على الاعمدة المجاورة لانها ربما تحتوي على معادلات 

جرب هدا 

Sub Supp_lignes_VidesArray()
Dim n&, i&, j&, k&, Irow&
Dim a As Variant, arr As Variant
Dim f As Worksheet: Set f = Sheets("Sheet1")
    
Irow = f.Columns("B:E").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    If Irow < 4 Then Exit Sub
     a = f.Range("B4:E" & Irow).Value
        For i = 1 To UBound(a, 1)
        If a(i, 1) <> "" And a(i, 2) <> "" And a(i, 3) <> "" And a(i, 4) <> "" Then
            n = n + 1
        End If
    Next i
    If n = 0 Then Exit Sub
    Application.ScreenUpdating = False
    ReDim arr(1 To n, 1 To UBound(a, 2))
    
    j = 0
    For i = 1 To UBound(a, 1)
        If a(i, 1) <> "" And a(i, 2) <> "" And a(i, 3) <> "" And a(i, 4) <> "" Then
            j = j + 1
            For k = 1 To UBound(a, 2)
                arr(j, k) = a(i, k)
            Next k
        End If
    Next i
    f.Range("B4:E" & Irow).ClearContents
    f.Range("B4").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    Application.ScreenUpdating = True
End Sub

وهدا في حالة كانت البيانات على الاعمدة B-C-D-E تحتوي على صيغ يجب الاحتفاظ بها عند التخلص من الخلايا الفارغة 

Sub Supp_lignes_Returns_formulas()
Dim n&, i&, j&, k&, Irow&
Dim a As Variant, arr As Variant
Dim f As Worksheet: Set f = Sheets("Sheet1")
Irow = f.Columns("B:E").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    If Irow < 4 Then Exit Sub
    a = f.Range("B4:E" & Irow).Value
    For i = 1 To UBound(a, 1)
        If a(i, 1) <> "" And a(i, 2) <> "" And a(i, 3) <> "" And a(i, 4) <> "" Then
            n = n + 1
        End If
    Next i
    If n = 0 Then Exit Sub
    
    ReDim arr(1 To n, 1 To UBound(a, 2))
    Application.ScreenUpdating = False
    j = 0
    For i = 1 To UBound(a, 1)
        If a(i, 1) <> "" And a(i, 2) <> "" And a(i, 3) <> "" And a(i, 4) <> "" Then
            j = j + 1
            For k = 1 To UBound(a, 2)
                If f.Cells(i + 3, k + 1).HasFormula Then
                    arr(j, k) = f.Cells(i + 3, k + 1).Formula
                Else
                    arr(j, k) = f.Cells(i + 3, k + 1).Value
                End If
            Next k
        End If
    Next i
    f.Range("B4:E" & Irow).ClearContents
    f.Range("B4").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    Application.ScreenUpdating = True
End Sub

 

New Microsoft Excel Worksheet v2.xlsb

تم تعديل سبتمبر 8 بواسطه محمد هشام.

[أبو عبد الله _]

جزاكم الله خيرا

الأخ أ / محمد صالح

والأخ محمد هشام 

 

الأكواد جميله وتفي بالغرض 

شكرا لكم

[أبو عبد الله _]

19 ساعات مضت, أ / محمد صالح said:

Sheets("Sheet1") ' قم بتغيير اسم الورقة حسب الحاجة

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

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

 

وشكرا

[محمد هشام.]

= ActiveSheet

 

[أبو عبد الله _]

23 ساعات مضت, محمد هشام. said:

Supp_lignes_VidesArray()
Dim n&, i&, j&, k&, Irow&
Dim a As Variant, arr As Variant
Dim f As Worksheet: Set f = Sheets("Sheet1")
    
Irow = f.Columns("B:E").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    If Irow < 4 Then Exit Sub
     a = f.Range("B4:E" & Irow).Value
        For i = 1 To UBound(a, 1)
        If a(i, 1) <> "" And a(i, 2) <> "" And a(i, 3) <> "" And a(i, 4)

الاستاذ محمد حاولت تعديل الكود 

ليتم التعامل مع الصف السابع 

وتكون البيانات من C:P

مع العلم B تحتوي على ترقيم تلقائي 

[محمد هشام.]

جرب هدا

Sub Supp_lignes_Returns_formulas()
    Dim lastRow&, i&, j&, k&, tpm&
    Dim OnRng As Variant, arr As Variant, b As Boolean
    Dim f As Worksheet: Set f = ActiveSheet
    
    lastRow = f.Columns("B:P").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    If lastRow < 7 Then Exit Sub
    Application.ScreenUpdating = False
    OnRng = f.Range("B4:P" & lastRow).Value
    tpm = 0
    For i = 1 To UBound(OnRng, 1)
        b = True
        For k = 1 To UBound(OnRng, 2)
            If IsEmpty(OnRng(i, k)) Then
                b = False
                Exit For
            End If
        Next k
        If b Then tpm = tpm + 1
    Next i
        If tpm = 0 Then Exit Sub
        ReDim arr(1 To tpm, 1 To UBound(OnRng, 2))
    j = 0
    For i = 1 To UBound(OnRng, 1)
        b = True
        For k = 1 To UBound(OnRng, 2)
            If IsEmpty(OnRng(i, k)) Then
                b = False
                Exit For
            End If
        Next k
        If b Then
            j = j + 1
            For k = 1 To UBound(OnRng, 2)
                If f.Cells(i + 3, k + 1).HasFormula Then
                    arr(j, k) = f.Cells(i + 3, k + 1).Formula
                Else
                    arr(j, k) = f.Cells(i + 3, k + 1).Value
                End If
            Next k
        End If
    Next i
    f.Range("B7:P" & lastRow).ClearContents
    If tpm > 0 Then
        f.Range("B7").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    End If
    Application.ScreenUpdating = True
End Sub

 

New Microsoft Excel Worksheet v2.xlsb

تم تعديل سبتمبر 9 بواسطه محمد هشام.

[محمد هشام.]

.

تم تعديل سبتمبر 9 بواسطه محمد هشام.

[أبو عبد الله _]

5 ساعات مضت, محمد هشام. said:

جرب هدا

 

 

 

test001.xlsm

1 ساعه مضت, محمد هشام. said:

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

تم الارفاق وشكرا لاهتمامك 

test001.xlsm

[محمد هشام.]

هناك اختلاف بين البيانات على الملف ومع طلبك الأول ماهو شرط إلغاء الصفوف الفارغة؟ 

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

 

 

 

test001.xlsm

تم تعديل سبتمبر 9 بواسطه محمد هشام.

[أبو عبد الله _]

شكرا لاهتمامك 

وربما أساءت التوضيح للمطلوب 

شرط الحذف أن تكون جميع الخلايا من c إلي P فارغة وإذا كانت هناك خلية غير فارغة لا يحذف شيء   أو  يكفي أن تكون D  ( الاسم ) فارغة ليتم التنفيذ 

مثال 

لو هناك اسم مكتوب ولا يوجد رقم أو لا توجد المحافظة لا يتم الحذف

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

لو جميع البيانات في الصف فارغة يتم الحذف

لو مكان الاسم فارغ يتم الحذف

 

لذك في الملف الذي قمت برفعه وضعت سطرين لتفريغ بيانات الصف بالكامل 

 

أشكر سعة صدرك وممتن لكم

 

 

[محمد هشام.]

إدن هدا سوف يوفي بالغرض

Sub Supp_lignes_Returns_formulas()

    Dim lr&, j&, i&, a, OnRng As Range
    Dim arr() As Variant, tmp As Variant
    Dim f As Worksheet: Set f = ActiveSheet
    
    lr = f.Columns("C:P").Find(What:="*", _
    SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    
    Set OnRng = f.Range("C7:P" & lr)
    tmp = OnRng.Value
    Application.ScreenUpdating = False
    ReDim arr(1 To UBound(tmp, 1), 1 To UBound(tmp, 2))
    a = 1
    For i = 1 To UBound(tmp, 1)
        If tmp(i, 2) <> "" And _
        WorksheetFunction.CountA(Application.Index(tmp, i, 0)) > 0 Then
            
            For j = 1 To UBound(tmp, 2)
                arr(a, j) = tmp(i, j)
            Next j
            a = a + 1
        End If
    Next i
    
        If a > 1 Then
        
        f.Range("C7:P" & lr).ClearContents
        f.Range("C7").Resize(a - 1, UBound(arr, 2)).Value = arr
    Else
        f.Range("C7:P" & lr).ClearContents
    End If
    Application.ScreenUpdating = True
End Sub

 

test002.xlsm

[أبو عبد الله _]

الأستاذ :محمد هشام 

ربما تعجز الكلمات عن وصف شكري وإمتنناني لك

جزاكم الله خيرا وأسعد الله أوقاتك 

 

وشكرا 

أ / محمد صالح 

وفق الله الجميع لما فيه الخير