كود تقسيم كل 10 أسماء فى صفحة منفصلة مع الإحتفاظ بنفس تنسيق الجدول

[محمد لؤي]

السلام عليكم - حياكم الله

عندي بيانات تأتي جاهزة 

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

اريد كل 10 اسماء بعض الخانات منها تجمع وكما موضح بالملف المرفق

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

 

تم تحديث الملف

تقسيم 2.xlsm

[نبيل عبد الهادي]

بعد اذن استاذ سليم 

تم تعديل رؤوس الاعمدة التي تمثل عناوين الجدول  ليتم اضافتها في كل ورقة جديدة 

عمل الكود:

1- هل  تريد  تحويل الصفوف الى اوراق جديدة ؟  اختر نعم

2- ادخل عدد الصفوف

3- هل تريد تضمين صف العناوين ؟ احتر نعم 

ملاحظه

- في الملف المرفق 1080 صف ويمثل عدد الاسماء .. سيتم انشاء  108 شيت !!

 - دمج  الخلايا سيؤدي الى اخطاء في الكود

 

تقسيم 2.xlsm

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

جرب هذا الكود (تم تغيير اسم الصفحة الرئيسية الى Salim) من اجل حسن نقل الكود  ولصقه

     بعض الأعمدة مخفية من الصفحة لنتمكن من رؤية كامل الجدول (يمكنك اظهارها بسهولة)

Option Explicit

Sub salim_code()
 Rem  Created By Salim Hasbaya On 15/4/2020
 Rem  you can change then Number 10 by _
      any number in all The code by changing ""tt""

Const tt = 10
Dim S As Worksheet, sh As Worksheet
Dim Ro%, i%, n%, m%, t%, x%, max_ro%
Dim arr()
Set S = Sheets("Salim")
Ro = S.Cells(Rows.Count, 1).End(3).Row
With Application
  .ScreenUpdating = False
  .Calculation = xlCalculationManual
End With
'-------------- Delete all sheets Except the Main sheet
 Application.DisplayAlerts = False
  For Each sh In Sheets
   If sh.Name <> S.Name Then
    sh.Delete
    End If
  Next
  Application.DisplayAlerts = True
 '--------------------------------------
 
m = Ro \ tt
n = (Ro Mod tt)
m = IIf(n = 0, m, m + 1)
 ReDim arr(1 To m)
 arr(1) = 2: arr(2) = tt
  For x = 3 To m
   arr(x) = arr(x - 1) + tt
  Next
For i = 1 To m
      S.Copy After:=Sheets(i)
        With ActiveSheet
          .Name = S.Name & i
          .Range("a1").CurrentRegion.Offset(1).Clear
            S.Range("A" & arr(i)).Resize(tt, 17).Copy
          .Cells(2, 1).PasteSpecial
          .Shapes.Range(Array("But_1")).Delete
          .Range("a1").Select
      End With
Next i
 With Sheets("Salim" & m)
  max_ro = .Cells(Rows.Count, 1).End(3).Row
    If max_ro = 1 Then
      Application.DisplayAlerts = False
      .Delete
      Application.DisplayAlerts = True
    ElseIf max_ro < tt + 1 Then
      .Range("A" & max_ro + 1).Resize(tt, 17).Clear
    End If
 End With
 With Application
  .ScreenUpdating = True
  .Calculation = xlCalculationAutomatic
  .CutCopyMode = False
  .DisplayAlerts = True
 End With
 S.Select: S.Range("a1").Select
End Sub

File Included

 

Taksim_By_10.xlsm

[محمد لؤي]

السلام عليكم - تعديل على كود من عمل الاستاذ سليم

مطلوب بعض التعديلات المبينة بالملف المرفق

 

كود للاستاذ سليم - اكرمه الله - تقسم الصفحة والجمع.xlsm

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

تم التعديل

Sub Salim_Total_new()

If ActiveSheet.Name <> "Taksim" Then Exit Sub
k = [S2]: My_Sum = "SUM OF :" & k
Application.ScreenUpdating = False
lr1 = [A9999].End(xlUp).Row
Cells(lr1 + 2, 1).EntireRow.Delete
Start_Row = 2
Last_Sum = lr1 - 2 'start row for the sum
sm_n = Int(Last_Sum / k) + 1     'Number of the sum_lines
On Error Resume Next
'=============================
Range("L3:L" & lr1).SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
'============================
On Error GoTo 0
lr = [A9999].End(xlUp).Row
    
For i = 1 To sm_n
    X = k + Start_Row              ' X is end row for the sum
    
    If X > (lr + 1) Then X = lr + 1: k = X - Start_Row
    lr = lr + 1
    Rows(X).Rows.Insert Shift:=xlDown
    Cells(X, "L") = My_Sum
    Cells(X, "M").Resize(, 4).FormulaR1C1 = "=SUM(R[-" & k & "]C:R[-1]C)"
    Cells(X, "O") = vbNullString
        With Range(Cells(X, 1), Cells(X, "P"))
            .Interior.ColorIndex = 6
            .Font.Bold = True
            .Font.Size = 14
        End With
        Start_Row = Start_Row + k + 1
        If Start_Row > lr Then GoTo 10
Next i
10  Application.ScreenUpdating = True
totalsum_new
With Range("A2:Q" & lr1 + 2)
.Value = .Value
.Borders.LineStyle = 1

End With
End Sub
Sub totalsum_new()

LAST = [A9999].End(xlUp).Row + 2
 Cells(LAST, "L") = "òALL SUM "
 Cells(LAST, "M").Resize(, 4).Formula = "=SUM(M3:M" & LAST - 1 & ")/ 2"
 Cells(LAST, "O") = vbNullString
With Cells(LAST, "L").Resize(, 5)
.Font.Bold = True
.Font.Size = 14
.Interior.Color = 10092492
End With

End Sub

الملف مرفق    صفحة" Taksim"

 

Sum_Of-10.xlsm

[محمد لؤي]

السلام عليكم

فرحت من رددت على طلبي - جزيت خيرا

ادخلت جزء من البيانات ولكن النتيجة لم تظهر - ممكن الاطلاع على الملف المرفق الذي يحتوي على البيانات

وكذلك رجعت للملف المرفق في المشاركة أعلاه ولكن لم تظهر النتائج

 

تقسيم كل عشرة صفوف.xlsm

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

يا صديقي انت تقوم بتنفيذ الماكرو على صفحة فارغة (لأن الماكرو يعمل فقط في صفحة Taksim من اجل عدم المساس في البيانات في صفحة اخرى عن طريق الخطأ )

  و كما ترى الصفحة Taksim فارغة 

في الملف المرفق يقوم الكود بنسخ الداتا من صفحة salim الى صفحة Taksim  ثم يقوم بترتيبها حسب الرقم في الخلية S2 من الصفحة  Taksim

لذلك اذا اردت تعديل او اضافة او حذف شيء ما  قم بذلك في الصفحة الاولى (salim) ثم اذهب الى الصفحة الثانية (Taksim) ونفذ الماكرو بالضغط على الزر

مرفق ملف مع بعض التعدبلات البسيطة

Talsim_by_10.xlsm

[محمد لؤي]

جزيت خيرا

بارك الله فيك

تسلم

هذا المطلوب