ترحيل بيانات من ورقة عمل رئيسي إلى مجموعة أوراق عمل

[علي بطيخ سالم]

هل من الممكن ترحيل البيانات بدلالة الزر بمعنى عندما أقوم بالضغط على زر (ترحيل إلى 1) مثلاً يرحل إلى الشيت (1) وعندما أضغط على زر (ترحيل إلى 2) يرحل إلى شيت (2) وهكذا، مع ملاحظة أنني سوف أقوم بمسح تلك البيانات من الصفحة الرئيسية بعد الترحيل لجلب بيانات أخرى جديدة (سوف أضيف زر مسح للبيانات القديمة وأريد البيانات المرحلة موجودة في الشيتات التي تم الترحيل إليها كما أنني أريد الترحيل بدلالة النوع إلى الصفحات المراد الترحيل إليها (أنظر شيت رقم 1) به أعمدة للذكور وأعمدة للإناث يعني المطلوب ترحيله من هذه الصفحة فقط عمود الإسم - الرقم القومي - حالة القيد - الديانة

علي بطيخ.xlsx

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

لا حاجة لعدد من الزرار يساوي عدد الشيتات 

الكود

Option Explicit
Sub get_Eleves_Names(ByVal my_SHEET As String)
Rem ====>>>> Created By Salim Hasbaya On 27/6/2019
'================================
Dim y%, SH As Worksheet
Dim ss%: ss = 0
 For y = 1 To Sheets.Count
  If Sheets(y).Name Like "*#*" Then
  ss = ss + 1
  End If
 Next



'============================
Dim m As Worksheet: Set m = Sheets("Main")
Dim Fst As Worksheet: Set Fst = Sheets(my_SHEET)
Dim Ar(4), Ar_Fasl(1 To 9)
Dim t: t = Sheets(my_SHEET).Index
Dim lrA%: lrA = m.Cells(Rows.Count, "A").End(3).Row
Dim lrF%: lrF = m.Cells(Rows.Count, "F").End(3).Row
Dim mal$: mal = "ذكر"
Dim fem$: fem = "انثى"
Dim i%
Dim Start_row_B%: Start_row_B = 10
Dim Start_row_H%: Start_row_H = 10
Fst.Range("b10").Resize(500, 11).ClearContents
 
With m
    For i = 2 To lrA
        Ar(0) = .Cells(i, "H"): Ar(1) = ""
        Ar(2) = .Cells(i, "G"): Ar(3) = .Cells(i, "A")
        Ar(4) = .Cells(i, "C")
         If .Range("B" & i) = mal Then
            Fst.Cells(Start_row_B, "B").Resize(, UBound(Ar) + 1) = Ar
            Start_row_B = Start_row_B + 1
           
         ElseIf .Range("B" & i) = fem Then
            Fst.Cells(Start_row_H, "H").Resize(, UBound(Ar) + 1) = Ar
            Start_row_H = Start_row_H + 1
         End If
    Next
   
 For i = 4 To 12
  Ar_Fasl(i - 3) = CStr(Fst.Cells(5, i))
 Next
 Fst.Range("c10").Resize(Start_row_B - 10) = _
 Application.Transpose(Ar_Fasl(t - 1))
 Fst.Range("I10").Resize(Start_row_H - 10) = _
 Application.Transpose(Ar_Fasl(t - 1))
 Fst.Range("K1") = ss
 End With
  Set m = Nothing: Set Fst = Nothing
  Erase Ar: Erase Ar_Fasl
End Sub
'==================================================
 Sub EXTACCT_NAME()
    Dim Impt
    Dim x%
    Impt = InputBox("Please Give_me the sheet's name to transfer data" & _
    Chr(10) & "Write the sheet's name  Without Cotes")
    If Impt = "Main" Then
     MsgBox "I can't Change the values of Principal Sheet"
    Exit Sub
    End If
   On Error Resume Next
    x = Len(Sheets(Impt).Name)
    If x = 0 Then
     On Error GoTo 0
     MsgBox "The Sheet: " & Impt & " Not Existes"
     Exit Sub
    End If
    Call get_Eleves_Names(Impt)
 End Sub

يكفي زر واحد و الماكرو يطلب منك اسم الشيت التي تريد الترحيل اليها مثل هذه الصورة(كتابة اسم الشيت بدون الأقواس)

الملف مرفق للمعاينة وابداء الرأي

 

 

 

 

Mes_Eleves_new.xlsm

[Ali Mohamed Ali]

هذا ابداع -بارك الله فيك استاذ سليم وجعله الله فى ميزان حسناتك

وايضا هذا الكود افضل ما يتم عمله فى هذه الحالة ولا يوجد أفضل من هذا لكى يقدم فى هذا العمل

زادك الله من فضله واحسن اليك ووسع الله فى رزقك

[علي بطيخ سالم]

ابداع استاذ علي  Ali Mohamed Ali بارك الله فيك وفي استاذنا استاذ أكواد الترحيل الاستاذ سليم حاصبيا وجعله الله في موازين حسناتكم

استاذ سليم حاصبيا جزاك الله خيراً وبارك الله لك وجعله الله في ميزان حسناتك ودائماً مبدع ويعجز اللسان عن الشكر بارك الله فيك

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

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

و اضافة الى ذلك ترقيم تلقائي للطلاب

Option Explicit
Sub get_Eleves_Names(ByVal my_SHEET As String)
Rem ====>>>> Created By Salim Hasbaya On 27/6/2019
Application.ScreenUpdating = False
'================================
Dim SH As Worksheet
Dim ss%
 For Each SH In Sheets
  If SH.Name Like "*#*" Then
  ss = ss + 1
  End If
 Next
 Set SH = Nothing
'============================
Dim m As Worksheet: Set m = Sheets("Main")
Dim But_Sheet As Worksheet: Set But_Sheet = Sheets(my_SHEET)
  But_Sheet.Range("K1") = ss: ss = 0
Dim Ar(4), Ar_Fasl(1 To 9)
Dim t: t = Sheets(my_SHEET).Index
Dim Start_row_B%: Dim Start_row_H%
Dim mal$: mal = "ذكر"
Dim fem$: fem = "انثى"
Dim i%

But_Sheet.Range("B10").Resize(500, 5).ClearContents
But_Sheet.Range("H10").Resize(500, 5).ClearContents
 '=======================================
 Dim Filtred_rg As Range: Set Filtred_rg = m.Range("a1").CurrentRegion
 Dim FinaL_row%: FinaL_row = Filtred_rg.Rows.Count
 
 For i = 4 To 12
  Ar_Fasl(i - 3) = CStr(But_Sheet.Cells(5, i))
 Next

With Filtred_rg
    .AutoFilter 2, mal
    
    .Columns(8).Offset(1).Resize(FinaL_row - 1, 1) _
        .SpecialCells(12).Copy But_Sheet.Range("B10")
    .Columns(7).Offset(1).Resize(FinaL_row - 1, 1) _
        .SpecialCells(12).Copy But_Sheet.Range("d10")
    .Columns(1).Offset(1).Resize(FinaL_row - 1, 1) _
        .SpecialCells(12).Copy But_Sheet.Range("e10")
    .Columns(3).Offset(1).Resize(FinaL_row - 1, 1) _
    .SpecialCells(12).Copy But_Sheet.Range("f10")
End With
'=======================================
With Filtred_rg
.AutoFilter 2, fem
.Columns(8).Offset(1).Resize(FinaL_row - 1, 1) _
    .SpecialCells(12).Copy But_Sheet.Range("h10")
.Columns(7).Offset(1).Resize(FinaL_row - 1, 1) _
    .SpecialCells(12).Copy But_Sheet.Range("j10")
.Columns(1).Offset(1).Resize(FinaL_row - 1, 1) _
    .SpecialCells(12).Copy But_Sheet.Range("k10")
.Columns(3).Offset(1).Resize(FinaL_row - 1, 1) _
    .SpecialCells(xlCellTypeVisible).Copy But_Sheet.Range("L10")
End With

Start_row_B = But_Sheet.Cells(Rows.Count, "B").End(3).Row
Start_row_H = But_Sheet.Cells(Rows.Count, "H").End(3).Row
 But_Sheet.Range("c10").Resize(Start_row_B - 9) = _
 Application.Transpose(Ar_Fasl(t - 1))
 
 But_Sheet.Range("i10").Resize(Start_row_H - 9) = _
 Application.Transpose(Ar_Fasl(t - 1))
  But_Sheet.Columns("A:L").AutoFit
'================================
If Sheets("Main").FilterMode Then _
Sheets("Main").ShowAllData: Filtred_rg.AutoFilter

  Set m = Nothing: Set But_Sheet = Nothing
  Erase Ar: Erase Ar_Fasl
  Application.ScreenUpdating = True
End Sub
'==================================================
 Sub EXTACCT_NAME()
    Dim Impt
    Dim x%
    Impt = InputBox("Please Give_me the sheet's name to transfer data" & _
    Chr(10) & "Write the sheet's name  Without Cotes")
    If UCase(Impt) = "MAIN" Then
     MsgBox "I can't Change the values of Principal Sheet"
    Exit Sub
    End If
   On Error Resume Next
    x = Len(Sheets(Impt).Name)
    If x = 0 Then
     On Error GoTo 0
     MsgBox "The Sheet: " & Impt & " Not Existes"
     Exit Sub
    End If
    Call get_Eleves_Names(Impt)
 End Sub

الملف من جديد

 

 

Mes_Eleves_Super.xlsm

[علي بطيخ سالم]

استاذنا الاستاذ سليم حاصبيا جزاك الله خيراً وبارك الله لك لقد قمت بالتعديل على الكود لترحيل بعض الأعمدة الأخرى لكنه يقوم بترحيل المعادلات دون القيم وأنا أريد ترحيل القيم دون المعادلات هل من طريقة لذلك وبارك الله لكم

القوائم جديدة.xlsm

[علي بطيخ سالم]

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

وأرجوا المعذرة فلم استطع وضع الردود  المتصفح كان لا يسمح مما اضطرني لكتابة موضوع جديد من متصفح آخر

 

القوائم جديدة.xlsm

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

نطاق الفاتر مؤلف من 10 اعمدة من A  الى J

لذلك لا يوجد عامود رقم 22 

[علي بطيخ سالم]

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

[علي بطيخ سالم]

16 ساعات مضت, سليم حاصبيا said:

نطاق الفاتر مؤلف من 10 اعمدة من A  الى J

لذلك لا يوجد عامود رقم 22 

استاذ سليم حاصبيا العمود رقم 22 هو هذا العمود استاذنا وهو يحتوي على دالة صفيف وعندما أضغط على زر الترحيل واضع رقم 1 على سبيل المثال في صفحة Main فانه يقوم بترحيل ما في صفحة Main إلى صفحة رقم 1 وفي عمود الفصل في خلايا c1 مثلاً يقوم بجلب دالة الصفيف بدلاً من القيمة فأنا أريد نسخ ما في هذا العمود رقم 22 والعمود رقم 34 ولصقهم في العمود c والعمود i  كقيم وليس كدالة أرجوا أن أكون قد وصلت المعلومة بطريقة صحيحة 

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

لم افهم ما تريد الضبط لان هناك في الملف معادلات مع Circular reference

لكني اتوقع هذا الكود يفي بالغرض

Option Explicit
Sub get_Eleves_Names(ByVal my_SHEET As String)
Rem ====>>>> Created By Salim Hasbaya On 27/6/2019
Application.ScreenUpdating = False
'================================
Dim SH As Worksheet
Dim ss%
 For Each SH In Sheets
  If SH.Name Like "*#*" Then
  ss = ss + 1
  End If
 Next
 Set SH = Nothing
'============================
Dim m As Worksheet: Set m = Sheets("Main")
Dim But_Sheet As Worksheet: Set But_Sheet = Sheets(my_SHEET)
  But_Sheet.Range("K1") = ss: ss = 0
Dim Ar(4), Ar_Fasl(1 To 9)
Dim t: t = Sheets(my_SHEET).Index
Dim Start_row_B%: Dim Start_row_H%
Dim mal$: mal = "ذكر"
Dim fem$: fem = "انثى"
Dim i%
Dim lrc%, LrI%

But_Sheet.Range("B10").Resize(500, 5).ClearContents
But_Sheet.Range("H10").Resize(500, 5).ClearContents
 '=======================================
 Dim Filtred_rg As Range: Set Filtred_rg = m.Range("a1").CurrentRegion
 Dim FinaL_row%: FinaL_row = Filtred_rg.Rows.Count
 
 For i = 4 To 12
  Ar_Fasl(i - 3) = CStr(But_Sheet.Cells(5, i))
 Next

With Filtred_rg
    .AutoFilter 2, mal
    
    .Columns(8).Offset(1).Resize(FinaL_row - 1, 1) _
        .SpecialCells(12).Copy But_Sheet.Range("B10")
    .Columns(7).Offset(1).Resize(FinaL_row - 1, 1) _
        .SpecialCells(12).Copy But_Sheet.Range("d10")
    .Columns(1).Offset(1).Resize(FinaL_row - 1, 1) _
        .SpecialCells(12).Copy But_Sheet.Range("e10")
    .Columns(3).Offset(1).Resize(FinaL_row - 1, 1) _
    .SpecialCells(12).Copy But_Sheet.Range("f10")
    lrc = Application.Max(But_Sheet.Range("a:a"))
    But_Sheet.Range("c10").Resize(lrc) = 1

End With
'=======================================
With Filtred_rg
.AutoFilter 2, fem
.Columns(8).Offset(1).Resize(FinaL_row - 1, 1) _
    .SpecialCells(12).Copy But_Sheet.Range("h10")
.Columns(7).Offset(1).Resize(FinaL_row - 1, 1) _
    .SpecialCells(12).Copy But_Sheet.Range("j10")
.Columns(1).Offset(1).Resize(FinaL_row - 1, 1) _
    .SpecialCells(12).Copy But_Sheet.Range("k10")
.Columns(3).Offset(1).Resize(FinaL_row - 1, 1) _
    .SpecialCells(xlCellTypeVisible).Copy But_Sheet.Range("L10")
    LrI = Application.Max(But_Sheet.Range("G:G")) - lrc
    But_Sheet.Range("i10").Resize(LrI) = 2

End With

Start_row_B = But_Sheet.Cells(Rows.Count, "B").End(3).Row
Start_row_H = But_Sheet.Cells(Rows.Count, "H").End(3).Row
 
  But_Sheet.Columns("A:L").AutoFit
'================================
If Sheets("Main").FilterMode Then _
Sheets("Main").ShowAllData: Filtred_rg.AutoFilter

  Set m = Nothing: Set But_Sheet = Nothing
  Erase Ar: Erase Ar_Fasl
  Application.ScreenUpdating = True
End Sub
'==================================================
 Sub EXTACCT_NAME()
    Dim Impt
    Dim x%
    Impt = InputBox("Please Give_me the sheet's name to transfer data" & _
    Chr(10) & "Write the sheet's name  Without Cotes")
    If UCase(Impt) = "MAIN" Then
     MsgBox "I can't Change the values of Principal Sheet"
    Exit Sub
    End If
   On Error Resume Next
    x = Len(Sheets(Impt).Name)
    If x = 0 Then
     On Error GoTo 0
     MsgBox "The Sheet: " & Impt & " Not Existes"
     Exit Sub
    End If
    Call get_Eleves_Names(Impt)
 End Sub

 

quawa3em.xlsm

[علي بطيخ سالم]

استاذ سليم حاصبيا في الصفحة الرئيسية Main يوجد عمودين العمود الأول v  وهو يبدأ ب كلمة (بنون) والعمود الثاني AH وهو يبدأ بكلمة بنات أريد ترحيل نفس القيم الموجودة بهم وهي عبارة عن أرقام الفصول للتلاميذ لتسكين كل مجموعة من التلاميذ في فصولهم بعدد معين والترحيل سوف يكون في عمود (C وعمود I) في باقي الصفحات وعند المحاولة حيث أنني عدلت على الكود الثاني الذي تفضلت بإرساله في المشاركة الثانية بإضافة السطر الذي أشرت إليه سابقاً 

هذين السطرين الذين أضفتهما بنفسي لنسخ العمود V  والعمود AH لكن عند ترحيلهما إلى الصفحات يقوم بترحيل الدالة بدلاً من القيمة 

 

تم تعديل يوليو 31, 2019 بواسطه علي بطيخ سالم

[علي بطيخ سالم]

أالقوائم جديدة.xlsmستاذ سليم حاصبيا هذا هو الملف الذي قمت بالتعديل عليه ولك أن تلاحظ ذلك بنفسك استاذنا في الأعمدة المشار إليها 

القوائم جديدة.xlsm

[علي بطيخ سالم]

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

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

الآن فهمت ما تريده

في الخلايا D6 و D7 من كل صفحة بدل الى هذه المعادلة  لتضبط الحسابات (تم التبديل)

=COUNT($C$10:$C$1100)

=COUNT($I$10:$I$1100)

الكود من جديد

Option Explicit
Sub get_Eleves_Names(ByVal my_SHEET As String)
Rem ====>>>> Created By Salim Hasbaya On 31/7/2019
Application.ScreenUpdating = False
'================================
Dim SH As Worksheet
Dim ss%
 For Each SH In Sheets
  If SH.Name Like "*#*" Then
  ss = ss + 1
  End If
 Next
 Set SH = Nothing
'============================
Dim m As Worksheet: Set m = Sheets("Main")
Dim But_Sheet As Worksheet: Set But_Sheet = Sheets(my_SHEET)
  But_Sheet.Range("K1") = ss: ss = 0
Dim Ar(4), Ar_Fasl(1 To 9)
Dim t: t = Sheets(my_SHEET).Index
Dim Start_row_B%: Dim Start_row_H%
Dim mal$: mal = "ذكر"
Dim fem$: fem = "انثى"
Dim i%
Dim RGU As Range: Set RGU = m.Range("v2", Range("v1").End(4))
Dim RGAH As Range: Set RGAH = m.Range("AH2", Range("AH1").End(4))
But_Sheet.Range("B10").Resize(500, 5).ClearContents
But_Sheet.Range("H10").Resize(500, 5).ClearContents
 '=======================================
 Dim Filtred_rg As Range: Set Filtred_rg = m.Range("a1").CurrentRegion
 Dim FinaL_row%: FinaL_row = Filtred_rg.Rows.Count
 
 For i = 4 To 12
  Ar_Fasl(i - 3) = CStr(But_Sheet.Cells(5, i))
 Next

With Filtred_rg
    .AutoFilter 2, mal
    
    .Columns(8).Offset(1).Resize(FinaL_row - 1, 1) _
        .SpecialCells(12).Copy But_Sheet.Range("B10")
    .Columns(7).Offset(1).Resize(FinaL_row - 1, 1) _
        .SpecialCells(12).Copy But_Sheet.Range("d10")
    .Columns(1).Offset(1).Resize(FinaL_row - 1, 1) _
        .SpecialCells(12).Copy But_Sheet.Range("e10")
    .Columns(17).Offset(1).Resize(FinaL_row - 1, 1) _
    .SpecialCells(12).Copy But_Sheet.Range("f10")

End With
     But_Sheet.Range("c10").Resize(RGU.Rows.Count).Value = _
     RGU.Value
'=======================================
With Filtred_rg
.AutoFilter 2, fem
.Columns(8).Offset(1).Resize(FinaL_row - 1, 1) _
    .SpecialCells(12).Copy But_Sheet.Range("h10")
.Columns(7).Offset(1).Resize(FinaL_row - 1, 1) _
    .SpecialCells(12).Copy But_Sheet.Range("j10")
.Columns(1).Offset(1).Resize(FinaL_row - 1, 1) _
    .SpecialCells(12).Copy But_Sheet.Range("k10")
.Columns(17).Offset(1).Resize(FinaL_row - 1, 1) _
    .SpecialCells(xlCellTypeVisible).Copy But_Sheet.Range("L10")

End With
    But_Sheet.Range("I10").Resize(RGAH.Rows.Count).Value = _
    RGAH.Value
  But_Sheet.Columns("A:L").AutoFit
'================================
If Sheets("Main").FilterMode Then _
Sheets("Main").ShowAllData: Filtred_rg.AutoFilter

  Set m = Nothing: Set But_Sheet = Nothing
  Erase Ar: Erase Ar_Fasl
  Application.ScreenUpdating = True
End Sub
'==================================================
 Sub EXTACCT_NAME()
    Dim Impt
    Dim x%
    Impt = InputBox("Please Give_me the sheet's name to transfer data" & _
    Chr(10) & "Write the sheet's name  Without Cotes")
    If UCase(Impt) = "MAIN" Then
     MsgBox "I can't Change the values of Principal Sheet"
    Exit Sub
    End If
   On Error Resume Next
    x = Len(Sheets(Impt).Name)
    If x = 0 Then
     On Error GoTo 0
     MsgBox "The Sheet: " & Impt & " Not Existes"
     Exit Sub
    End If
    Call get_Eleves_Names(Impt)
 End Sub

الملف الجديد

 

 

Students_names.xlsm

[علي بطيخ سالم]

استاذنا الاستاذ سليم حاصبيا حياك الله وبارك الله لك وجزاك الله خيراً استاذنا هذا هو المطلوب بالضبط شكراً لك استاذنا

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

14 دقائق مضت, علي بطيخ سالم said:

استاذنا الاستاذ سليم حاصبيا حياك الله وبارك الله لك وجزاك الله خيراً استاذنا هذا هو المطلوب بالضبط شكراً لك استاذنا

هذه الاسطر من الكود يمكن ازالتها لانها تثقل البرنامج بدون منفعة(كانت للكود القديم)

Dim Ar(4), Ar_Fasl(1 To 9)
Dim t: t = Sheets(my_SHEET).Index
Dim Start_row_B%: Dim Start_row_H%

 For i = 4 To 12
  Ar_Fasl(i - 3) = CStr(But_Sheet.Cells(5, i))
 Next

Erase Ar: Erase Ar_Fasl

 

[علي بطيخ سالم]

استاذنا الاستاذ سليم حاصبيا بارك الله لك .... على مجهودك العظيم ولي تساؤل آخير : الملف به مجموعة أكود في الصفحة الرئيسية كل كود يؤدي غرض معين هل يمكن دمج جميع هذه الأكود مع بعضها لتعمل بضغطة زر واحد بدلاً من مجموعة الأزرار التي تملأ الصفحة بدون فائدة : فهناك كود للترتيب الأبجدي وكود آخر لاستبدال كلمات معينة مثل راسب وباق للاعادة أو ناجح ومنقول وكود آخر لتحويل كلمة مسلم إذا كانت أنثى إلى مسلمة، وأريد ضم جميع هذه الأكواد في كود واحد يجمعهم بأمر واحد بدلاً من الضغط على كل زر منفرد (لكن شرط أن يكون الترتيب الأبجدي هو أول هذه الأوامر) وجزاك الله خيراً وعذراً على كثرة تساؤلاتي لكن منكم نتعلم استاذنا