كود إدخال 3 صفوف فارغة بعد كل 10 صفوف متسلسلة

[faicale]

ارجو المساعدة في excel : عندي list في الاكسل متسلسل متكون من 670 سطر . اريد ان اضع 3 اسطر فارغين بعد كل 10 سطر الى غاية مااوصل للاخر . مثال:
2020002163
2020004140
2020004175
2020004684
2020004726
2020004828
2020001754
2017000710
2018004163
2017005535



2018006116
2020004018
2018000030
2018000325
2019000358
2020000350
2020000661
2020000671
2020001851
2020002216



2020002268
2020002346
2018000137
2018000215
2018000217
2018000224
2018000282
.
.
.الخ...

ممكن طريقة عبر VBA أو خاصية تتعمل بشكل تلقائي  ؟؟؟؟؟

عنوان مخالف ... تم تعديل عنوان المشاركة ليعبر عن طلبك , وكان لابد من رفع الملف

[محي الدين ابو البشر]

صباح الخير

ربما؟

اعبار أن ألداتا تبدأ من الخلية (ِA1)

Sub test()
    Dim i
    For i = 670 To 1 Step -10
        Cells(i - 9, 1).Resize(3).Select
        Selection.Insert Shift:=xlDown
    Next
End Sub

 

[سليم حاصبيا]

بعد اذن اخي محي الدين

كان من المفروض رفع ملف     لكن لأول مرة اليك هذا النموذج

الكود

Option Explicit
Rem This Macro Insert chossen Number Of rows Every n Number
Sub salim_rows()
Dim t%, lr%, x%, z%, a%
Dim my_rg As Range
Application.ScreenUpdating = False
If ActiveSheet.Name <> "Salim" Then GoTo End_Me
 If Val(Range("E2")) <= 0 _
 Or Val(Range("F2")) <= 0 Then
 GoTo End_Me
 End If
z = Int(Range("E2")) 'number of rows to be insert every time
a = Int(Range("F2")) 'number of rows for every group
 Range("G2") = 4
 x = 4
If a <= 0 Then Exit Sub
t = x + a + 1
If z > 5 Then z = 5

lr = Cells(Rows.Count, 1).End(3).Row
On Error Resume Next
Set my_rg = Range("a" & x & ":a" & lr).SpecialCells(4)
my_rg.EntireRow.Delete
On Error GoTo 0
    Do Until Cells(t, "A") = ""
        Rows(t).Resize(z).Insert
        t = t + z + a
    Loop
End_Me:
Application.ScreenUpdating = True
End Sub
'+++++++++++++++++++++++++++++++++
Sub del_Empty_rows()
Dim ro%, Rg As Range
ro = Cells(Rows.Count, 1).End(3).Row
If ro < 4 Then Exit Sub
 Range("G2") = 4
  On Error Resume Next
    Set Rg = Range("A4" & ":A" & ro).SpecialCells(4)
    Rg.EntireRow.Delete
  On Error GoTo 0

End Sub

صورة توضح كيفية التعامل مع الملف

الملف مرفق

Insert_N_Rows.xlsm

[faicale]

الله عليك.... رغم اني اتلخبطت في الاكواد ومفهمتهاش خبرتي لاشيء .... لكن النتيجة مذهلة....

واستسمح عن عدم ارفاق الملف من الاول ذلك حاولت اشرح الفكرة : هو انني اتوصل يوميا بليست تكون متغيرة في عدد صفوفها يمكن يوم توصل 100 صف ويوم 5000 صف حسب الادارة ودوري فيها ينحصر كل يوم اوزع الليست بالتساوي الى عدد الافراد = عدد الصفوف مثلا : عندي 20 مستخدم لازم عليا ان اقسم 1000 صف في الليست / 20 شخص بمعنى 50 صف لكل واحد فيهم.... لكن اواجه مشكلة لو سمحت ممكن تعدل الكود السابق يكون ايضا فيه عملية خلط الليست قبل ما اوزعها عليهم يعني الليست بتكون مترتبة وحابب تكون عشوائية مثل خاصية  ALEA().... واستعمال الاسماء للتقسيم لتطلع في الاخير جدول كل واحد وحصته من الليست.

ألف تحية لكم

 

rapport list.xlsx

تم تعديل أكتوبر 3, 2020 بواسطه faicale

[سليم حاصبيا]

هذا الكود يقوم بادراج جدول عشوائي في الشيت (Salim) للبيانات الموجودة  في الشيت  (Page1_1)

Option Explicit

Sub Salim_rand_table()
If ActiveSheet.Name <> "Salim" Then Exit Sub
    Dim S As Worksheet
    Dim P As Worksheet
    Dim i%, k%, New_arr()
    Dim Rop%, Ros%, myEnd%
    Dim my_rg As Range, Rgs As Range, RgP As Range

    Set S = Sheets("Salim")
    Set P = Sheets("Page1_1")
    Set Rgs = S.Range("B1").CurrentRegion
    Ros = Rgs.Rows.Count

If Ros > 1 Then
  Rgs.Offset(1).Resize(Ros - 1).ClearContents
End If

 myEnd = Application.CountA(P.Range("B:B")) - 1
 Set my_rg = P.Cells(2, 2).Resize(myEnd)
 With CreateObject("System.Collections.SortedList")
    For i = 1 To myEnd
       .Item(Rnd) = i
    Next i
    
     ReDim New_arr(1 To .Count)
   For k = 1 To .Count
      New_arr(k) = Val(my_rg.Cells(.GetByIndex(k - 1)))
   Next
 End With
 With S.Range("B2").Resize(UBound(New_arr))
 .Value = Application.Transpose(New_arr)
 .Value = .Value
 End With
End Sub

الملف مرفق ( فقط اضغط غلى الزر Tableau aléatoire) في الشيت (Salim)

 

faicale_table.xlsm

[سليم حاصبيا]

تم التعديل على الملف ليعمل كما تريد

Option Explicit
 Dim S As Worksheet
    Dim P As Worksheet
    Dim i%, k%, New_arr()
    Dim Rop%, Ros%, myEnd%
    Dim my_rg As Range, rgs As Range, RgP As Range
Sub Salim_rand_table()
If ActiveSheet.Name <> "Salim" Then GoTo End_Me
Application.ScreenUpdating = False
    Set S = Sheets("Salim")
    Set P = Sheets("Page1_1")
    Set rgs = S.Range("B1").CurrentRegion
    Ros = rgs.Rows.Count

If Ros > 1 Then
  rgs.Offset(1).Resize(Ros - 1).ClearContents
End If

 myEnd = Application.CountA(P.Range("B:B")) - 1
 Set my_rg = P.Cells(2, 2).Resize(myEnd)
 With CreateObject("System.Collections.SortedList")
    For i = 1 To myEnd
       .Item(Rnd) = i
    Next i
    
     ReDim New_arr(1 To .Count)
   For k = 1 To .Count
      New_arr(k) = Val(my_rg.Cells(.GetByIndex(k - 1)))
   Next
 End With
 With S.Range("B2").Resize(UBound(New_arr))
 .Value = Application.Transpose(New_arr)
 .Value = .Value
 End With
 Please_Collction
End_Me:
 Application.ScreenUpdating = True
End Sub
'+++++++++++++++++++++++++++
Sub Please_Collction()
Application.ScreenUpdating = False
Dim x, y
 Set S = Sheets("Salim")
    Set rgs = S.Range("B1").CurrentRegion
    Ros = rgs.Rows.Count
  If Val(S.Range("L1")) <= 0 Then
   S.Range("L1") = 10
  End If

  S.Range("C2").Resize(Ros).UnMerge
  S.Range("C2").Resize(Ros).Clear

   k = 1
   For i = 2 To Ros Step Int(S.Range("L1"))
     Cells(i, 3) = "Equipe :" & k
     Cells(i, 3).Resize(Int(S.Range("L1"))).Merge
     k = k + 1
   Next
  With S.Range("C2").Resize(Ros)
   .VerticalAlignment = 2
   .HorizontalAlignment = 3
   .Borders.LineStyle = 1
   .Font.Size = 16
   .Font.Bold = True
  End With
  Application.ScreenUpdating = True
End Sub
'++++++++++++++++++++++++++++++

الملف من جديد

 

faicale_table_1.xlsm

[faicale]

تحية خاصة اليك je te remercie infiniment