اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

الردود الموصى بها

قام بنشر

هل من الممكن ترحيل البيانات بدلالة الزر بمعنى عندما أقوم بالضغط على زر (ترحيل إلى 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

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

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

 

 

 

 

Mes_Eleves_new.xlsm

  • Like 3
  • Thanks 1
قام بنشر

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

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

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

  • Like 2
  • Thanks 1
قام بنشر

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

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

  • Like 1
قام بنشر

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

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

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

  • Like 3
  • Thanks 1
قام بنشر

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

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

قام بنشر

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

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

 

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

قام بنشر

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

2.png

العمود رقم 22.png

قام بنشر
16 ساعات مضت, سليم حاصبيا said:

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

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

Cap.PNG

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

العمود رقم 22.png

قام بنشر

لم افهم ما تريد الضبط لان هناك في الملف معادلات مع 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) في باقي الصفحات وعند المحاولة حيث أنني عدلت على الكود الثاني الذي تفضلت بإرساله في المشاركة الثانية بإضافة السطر الذي أشرت إليه سابقاً 

11.png

22.png

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

 

33.png

تم تعديل بواسطه علي بطيخ سالم
قام بنشر

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

44.png

44.png

  • أفضل إجابة
قام بنشر

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

في الخلايا 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

  • Like 1
قام بنشر
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

 

  • Like 2
قام بنشر

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

 

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information