أبو عبد الله _ قام بنشر سبتمبر 8 مشاركة قام بنشر سبتمبر 8 السلام عليكم ورحمة الله وبركاته اريد طريق للتخلص من الفراغات بدون التأثير على المدى في المعادلات New Microsoft Excel Worksheet.xlsx رابط هذا التعليق شارك More sharing options...
أ / محمد صالح قام بنشر سبتمبر 8 مشاركة قام بنشر سبتمبر 8 عليكم السلام ورحمة الله وبركاته يمكنك تجربة هذا الكود 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 بالتوفيق 2 رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر سبتمبر 8 مشاركة قام بنشر سبتمبر 8 (معدل) وعليكم السلام ورحمة الله تعالى وبركاته بعد معاينة الملف لاحظت انك ترغب بحدف الخلايا الفارغة مع البقاء على البيانات بمكانها الاصلي مع مراعات عدم التاثير على الاعمدة المجاورة لانها ربما تحتوي على معادلات جرب هدا 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 بواسطه محمد هشام. 2 رابط هذا التعليق شارك More sharing options...
أبو عبد الله _ قام بنشر سبتمبر 8 الكاتب مشاركة قام بنشر سبتمبر 8 جزاكم الله خيرا الأخ أ / محمد صالح والأخ محمد هشام الأكواد جميله وتفي بالغرض شكرا لكم 1 رابط هذا التعليق شارك More sharing options...
أبو عبد الله _ قام بنشر سبتمبر 9 الكاتب مشاركة قام بنشر سبتمبر 9 19 ساعات مضت, أ / محمد صالح said: Sheets("Sheet1") ' قم بتغيير اسم الورقة حسب الحاجة هل يمكن التغير هنا بحيث يكون الحذف من ورقة العمل النشطة بدون تحديد اسم بحيث يتم استخدام الكود في اي مكان دون الحاجة لتكراره وشكرا رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر سبتمبر 9 مشاركة قام بنشر سبتمبر 9 = ActiveSheet 1 رابط هذا التعليق شارك More sharing options...
أبو عبد الله _ قام بنشر سبتمبر 9 الكاتب مشاركة قام بنشر سبتمبر 9 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 تحتوي على ترقيم تلقائي رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر سبتمبر 9 مشاركة قام بنشر سبتمبر 9 (معدل) جرب هدا 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 بواسطه محمد هشام. رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر سبتمبر 9 مشاركة قام بنشر سبتمبر 9 (معدل) . تم تعديل سبتمبر 9 بواسطه محمد هشام. رابط هذا التعليق شارك More sharing options...
أبو عبد الله _ قام بنشر سبتمبر 9 الكاتب مشاركة قام بنشر سبتمبر 9 5 ساعات مضت, محمد هشام. said: جرب هدا test001.xlsm 1 ساعه مضت, محمد هشام. said: من الأفضل دائما إرفاق عينة من ملفك للإطلاع على شكل البيانات والصيغ الموجودة ربما هناك طرق أسهل من هذا كله للتعامل مع الصفوف الفارغة مع مراعات عدم حدف معادلة الترقيم أو ربما حذفها وإعادة تسلسل البيانات بالأكواد تم الارفاق وشكرا لاهتمامك test001.xlsm رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر سبتمبر 9 مشاركة قام بنشر سبتمبر 9 (معدل) هناك اختلاف بين البيانات على الملف ومع طلبك الأول ماهو شرط إلغاء الصفوف الفارغة؟ الكود التالي يقوم بحذف الفراغات في حالة التحقق من وجود خلية واحدة فارغة في الأعمدة C إلى P مع الاحتفاظ بعمود التسلسل test001.xlsm تم تعديل سبتمبر 9 بواسطه محمد هشام. رابط هذا التعليق شارك More sharing options...
أبو عبد الله _ قام بنشر سبتمبر 9 الكاتب مشاركة قام بنشر سبتمبر 9 شكرا لاهتمامك وربما أساءت التوضيح للمطلوب شرط الحذف أن تكون جميع الخلايا من c إلي P فارغة وإذا كانت هناك خلية غير فارغة لا يحذف شيء أو يكفي أن تكون D ( الاسم ) فارغة ليتم التنفيذ مثال لو هناك اسم مكتوب ولا يوجد رقم أو لا توجد المحافظة لا يتم الحذف لو هناك اسم والكود غير موجود لا يتم الحذف لو جميع البيانات في الصف فارغة يتم الحذف لو مكان الاسم فارغ يتم الحذف لذك في الملف الذي قمت برفعه وضعت سطرين لتفريغ بيانات الصف بالكامل أشكر سعة صدرك وممتن لكم رابط هذا التعليق شارك More sharing options...
أفضل إجابة محمد هشام. قام بنشر سبتمبر 9 أفضل إجابة مشاركة قام بنشر سبتمبر 9 إدن هدا سوف يوفي بالغرض 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 2 رابط هذا التعليق شارك More sharing options...
أبو عبد الله _ قام بنشر سبتمبر 10 الكاتب مشاركة قام بنشر سبتمبر 10 الأستاذ :محمد هشام ربما تعجز الكلمات عن وصف شكري وإمتنناني لك جزاكم الله خيرا وأسعد الله أوقاتك وشكرا أ / محمد صالح وفق الله الجميع لما فيه الخير رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان