علي بطيخ سالم قام بنشر يوليو 25, 2019 قام بنشر يوليو 25, 2019 هل من الممكن ترحيل البيانات بدلالة الزر بمعنى عندما أقوم بالضغط على زر (ترحيل إلى 1) مثلاً يرحل إلى الشيت (1) وعندما أضغط على زر (ترحيل إلى 2) يرحل إلى شيت (2) وهكذا، مع ملاحظة أنني سوف أقوم بمسح تلك البيانات من الصفحة الرئيسية بعد الترحيل لجلب بيانات أخرى جديدة (سوف أضيف زر مسح للبيانات القديمة وأريد البيانات المرحلة موجودة في الشيتات التي تم الترحيل إليها كما أنني أريد الترحيل بدلالة النوع إلى الصفحات المراد الترحيل إليها (أنظر شيت رقم 1) به أعمدة للذكور وأعمدة للإناث يعني المطلوب ترحيله من هذه الصفحة فقط عمود الإسم - الرقم القومي - حالة القيد - الديانة علي بطيخ.xlsx
سليم حاصبيا قام بنشر يوليو 26, 2019 قام بنشر يوليو 26, 2019 لا حاجة لعدد من الزرار يساوي عدد الشيتات الكود 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 3 1
Ali Mohamed Ali قام بنشر يوليو 26, 2019 قام بنشر يوليو 26, 2019 هذا ابداع -بارك الله فيك استاذ سليم وجعله الله فى ميزان حسناتك وايضا هذا الكود افضل ما يتم عمله فى هذه الحالة ولا يوجد أفضل من هذا لكى يقدم فى هذا العمل زادك الله من فضله واحسن اليك ووسع الله فى رزقك 2 1
علي بطيخ سالم قام بنشر يوليو 26, 2019 الكاتب قام بنشر يوليو 26, 2019 ابداع استاذ علي Ali Mohamed Ali بارك الله فيك وفي استاذنا استاذ أكواد الترحيل الاستاذ سليم حاصبيا وجعله الله في موازين حسناتكم استاذ سليم حاصبيا جزاك الله خيراً وبارك الله لك وجعله الله في ميزان حسناتك ودائماً مبدع ويعجز اللسان عن الشكر بارك الله فيك 1
سليم حاصبيا قام بنشر يوليو 26, 2019 قام بنشر يوليو 26, 2019 تطوير بسيط على الكود ليكون بشكل أسرع بكثير معتمداً على الفلتر وليس الحلقات التكرارية المملة والمرهقة للبرنامج و اضافة الى ذلك ترقيم تلقائي للطلاب 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 3 1
علي بطيخ سالم قام بنشر يوليو 30, 2019 الكاتب قام بنشر يوليو 30, 2019 استاذنا الاستاذ سليم حاصبيا جزاك الله خيراً وبارك الله لك لقد قمت بالتعديل على الكود لترحيل بعض الأعمدة الأخرى لكنه يقوم بترحيل المعادلات دون القيم وأنا أريد ترحيل القيم دون المعادلات هل من طريقة لذلك وبارك الله لكم القوائم جديدة.xlsm
علي بطيخ سالم قام بنشر يوليو 30, 2019 الكاتب قام بنشر يوليو 30, 2019 السلام عليكم ورحمة الله وبركاته هذا الكود من عمل أستاذنا الفاضل الأستاذ سليم حصيبا جزاه الله خيراً لكن عندما أقوم بترحيل عمود بنين وعمود بنات يقوم بترحيلهم كمعادلات وأنا أريد القيم فقط يعني 1111111111111111111122222222222 وهكذا وجزاكم الله خيراً وأرجوا المعذرة فلم استطع وضع الردود المتصفح كان لا يسمح مما اضطرني لكتابة موضوع جديد من متصفح آخر القوائم جديدة.xlsm
سليم حاصبيا قام بنشر يوليو 30, 2019 قام بنشر يوليو 30, 2019 نطاق الفاتر مؤلف من 10 اعمدة من A الى J لذلك لا يوجد عامود رقم 22 2
علي بطيخ سالم قام بنشر يوليو 31, 2019 الكاتب قام بنشر يوليو 31, 2019 استاذنا الاستاذ سليم حاصبيا الملف شغال كويس معي لكن ما أقصده هل ممكن أنه ينسخ قيمة العمود بدلاً من المعادلة فعندما أضغط على زر الترحيل يقوم بترحيل المعادلة بدلاً من القيم الموجودة في المعمود
علي بطيخ سالم قام بنشر يوليو 31, 2019 الكاتب قام بنشر يوليو 31, 2019 16 ساعات مضت, سليم حاصبيا said: نطاق الفاتر مؤلف من 10 اعمدة من A الى J لذلك لا يوجد عامود رقم 22 استاذ سليم حاصبيا العمود رقم 22 هو هذا العمود استاذنا وهو يحتوي على دالة صفيف وعندما أضغط على زر الترحيل واضع رقم 1 على سبيل المثال في صفحة Main فانه يقوم بترحيل ما في صفحة Main إلى صفحة رقم 1 وفي عمود الفصل في خلايا c1 مثلاً يقوم بجلب دالة الصفيف بدلاً من القيمة فأنا أريد نسخ ما في هذا العمود رقم 22 والعمود رقم 34 ولصقهم في العمود c والعمود i كقيم وليس كدالة أرجوا أن أكون قد وصلت المعلومة بطريقة صحيحة
سليم حاصبيا قام بنشر يوليو 31, 2019 قام بنشر يوليو 31, 2019 لم افهم ما تريد الضبط لان هناك في الملف معادلات مع 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
علي بطيخ سالم قام بنشر يوليو 31, 2019 الكاتب قام بنشر يوليو 31, 2019 (معدل) استاذ سليم حاصبيا في الصفحة الرئيسية Main يوجد عمودين العمود الأول v وهو يبدأ ب كلمة (بنون) والعمود الثاني AH وهو يبدأ بكلمة بنات أريد ترحيل نفس القيم الموجودة بهم وهي عبارة عن أرقام الفصول للتلاميذ لتسكين كل مجموعة من التلاميذ في فصولهم بعدد معين والترحيل سوف يكون في عمود (C وعمود I) في باقي الصفحات وعند المحاولة حيث أنني عدلت على الكود الثاني الذي تفضلت بإرساله في المشاركة الثانية بإضافة السطر الذي أشرت إليه سابقاً هذين السطرين الذين أضفتهما بنفسي لنسخ العمود V والعمود AH لكن عند ترحيلهما إلى الصفحات يقوم بترحيل الدالة بدلاً من القيمة تم تعديل يوليو 31, 2019 بواسطه علي بطيخ سالم
علي بطيخ سالم قام بنشر يوليو 31, 2019 الكاتب قام بنشر يوليو 31, 2019 أالقوائم جديدة.xlsmستاذ سليم حاصبيا هذا هو الملف الذي قمت بالتعديل عليه ولك أن تلاحظ ذلك بنفسك استاذنا في الأعمدة المشار إليها القوائم جديدة.xlsm
علي بطيخ سالم قام بنشر يوليو 31, 2019 الكاتب قام بنشر يوليو 31, 2019 هذه الأرقام المشار إليها في الكود الجديد متغيرة استاذنا بمعنى أنا ممكن اقسم عدد البنين مثلاً على 4 فصول أو 5 فصول وهكذا بالنسبة للبنات وهذا التقسيم معتمد على نظام حسابات موجود في نفس الصفحة الرئيسية بحيث أقوم أنا بوضع العدد المراد تقسيم التلاميذ عليه ويقوم البرنامج بتقسيم التلاميذ تلقائياً
أفضل إجابة سليم حاصبيا قام بنشر يوليو 31, 2019 أفضل إجابة قام بنشر يوليو 31, 2019 الآن فهمت ما تريده في الخلايا 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 1
علي بطيخ سالم قام بنشر يوليو 31, 2019 الكاتب قام بنشر يوليو 31, 2019 استاذنا الاستاذ سليم حاصبيا حياك الله وبارك الله لك وجزاك الله خيراً استاذنا هذا هو المطلوب بالضبط شكراً لك استاذنا 1
سليم حاصبيا قام بنشر يوليو 31, 2019 قام بنشر يوليو 31, 2019 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 2
علي بطيخ سالم قام بنشر أغسطس 1, 2019 الكاتب قام بنشر أغسطس 1, 2019 استاذنا الاستاذ سليم حاصبيا بارك الله لك .... على مجهودك العظيم ولي تساؤل آخير : الملف به مجموعة أكود في الصفحة الرئيسية كل كود يؤدي غرض معين هل يمكن دمج جميع هذه الأكود مع بعضها لتعمل بضغطة زر واحد بدلاً من مجموعة الأزرار التي تملأ الصفحة بدون فائدة : فهناك كود للترتيب الأبجدي وكود آخر لاستبدال كلمات معينة مثل راسب وباق للاعادة أو ناجح ومنقول وكود آخر لتحويل كلمة مسلم إذا كانت أنثى إلى مسلمة، وأريد ضم جميع هذه الأكواد في كود واحد يجمعهم بأمر واحد بدلاً من الضغط على كل زر منفرد (لكن شرط أن يكون الترتيب الأبجدي هو أول هذه الأوامر) وجزاك الله خيراً وعذراً على كثرة تساؤلاتي لكن منكم نتعلم استاذنا
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.