سليم حاصبيا

الكود اللازم مع التنسيق بعد الترحيل Option Explicit Dim Source As Worksheet Dim Target As Worksheet Dim Mx%, i%, rO% Dim Ar_S Dim Ar_T '++++++++++++++++++++++++++++++++++++++++++++ Sub Fayez() Set Source = Sheets("sheet1") Set Target = Sheets("sheet2") Mx = Target.Cells(Rows.Count, 2).End(3).Row + 1 Ar_S = Array("D7", "D9", "D11", "G7", "G9", "G11", "G13") Ar_T = Array("B", "C", "D", "E", "F", "G", "H") For i = LBound(Ar_S) To UBound(Ar_S) Target.Cells(Mx, Ar_T(i)) = Source.Range(Ar_S(i)) Source.Range(Ar_S(i)) = vbNullString Next 'هذا السطر لحذف البيانات المكررة اذا لا تريده يمكنك حذفه '+++++++++++++++++++++++++++++++++++++++ Target.Range("A1:H" & Mx).RemoveDuplicates _ Columns:=Array(1, 2, 2, 2, 5, 6, 7), Header:=1 '++++++++++++++++++++++++++++++++++++++++ rO = Target.Range("b2").CurrentRegion.Rows.Count If rO > 1 Then With Target.Range("b2").CurrentRegion. _ Offset(1).Resize(rO - 1) .HorizontalAlignment = 1 .Borders.LineStyle = 1 .InsertIndent 1 .Font.Bold = True .Font.Size = 16 .Cells(1, 1).Resize(rO - 1).Value = _ Evaluate("row(1:" & rO - 1 & ")") End With End If End Sub الملف مرفق esam1983.xlsm

صراحة لا أعرف عن اي يوزر تتكلم هناك اكثر من 15 يوزر ارفع نموذج عن الملف مبسط (صفحتين فقط واحدة للترحيل واخرى للاستقبال) ولا يحتوي على كل هذه اليوزر ولا كل هذه الـــ Modules التي عددها بفوق اللــ 20

في هذا الملف 1- الصفحة Result حيث تظهر النتيجة 3 صفوف تحنوي بيانات مهمه ليغمل عليها الكود الصفوف (5/4/3 مخفية) عدم المس بها كي لا يتعطل عمل الماكرو الصف رقم 5 يجب ان يكون فارغاُ نهائياً لقصل رأس الجدول عن البيانات 2-تكرار البيانات غير مسموح (الماكرو يحذف المكرر اذا كانت جميع بيانات الصف الواجد مكررة) بمعنى اخر اذا كبست الزر اكثر من مرة دون تعديل البيانات لا يعمل الماكرو أكثر من مرة واحدة الماكرو 3 -الزر Clear يمسح البيانات من source التي لا تحتوي على معادلات Option Explicit Sub Get_data() Dim S As Worksheet Dim R As Worksheet Dim i%, m%, Mx% Dim ArS(1 To 20) Dim ArR(1 To 20) Set S = Sheets("Source") Set R = Sheets("Result") m = R.Cells(Rows.Count, 2).End(3).Row + 1 If m < 6 Then m = 6 For i = 2 To 21 ArS(i - 1) = R.Cells(3, i) ArR(i - 1) = R.Cells(4, i) Next For i = 1 To 20 R.Cells(m, ArR(i)).Value = _ S.Range(ArS(i)).Value Next R.Cells(6, 2).Resize(m - 5, 20). _ RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, _ 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20), Header:=xlNo Mx = R.Range("B6").CurrentRegion.Rows.Count If R.Cells(6, 2) <> vbNullString Then With R.Cells(6, 1).Resize(Mx) .Value = Evaluate("Row(1:" & Mx & ")") With .Resize(, 21) .Borders.LineStyle = 1 .Font.Bold = True End With End With End If End Sub الملف مرفق laminedch.xlsm

جرب هذا الملف solventer.xlsx

عدم المواخذة الحل الأول لا يعطي النتيجة الصحيحة وإن كان الأولى أرتب قليلا ( لأنه عملية Format Number للخلية وهذا لا يغير قيمة الخلية بل يغير منظرها أو واجهتها ) اي انك تري الرقم مقسوماً على 1000 في الخلية فقط بينما في الحقيقة قيمتها هي نفسها كما ترى في الــــ(formula bar) و هكذا الـــ Format Number هو مجرد قناع للخلية لا يحميها من الكورونا اي (formula bar) الصورة والمعادلة فيها تؤكد ذلك (لو ان الخلية 4.00 تساوي 4 بالحقيقة لكانت نتيجة المعادلة 504 و كذلك الأمر بالنسبة للخلية 0.01 قيمتها الحقيقية 12 لأن نتيجة المعادلة 512 يمكنك تحديد هذه الخلية والنظر الى كاشف الفضائح الذي لا يخبىء سراَ مثل النسوان تجتفظ بالسر حتى أقرب هاتف واليوم أقرب هاتف هو الخلوي في جزدانها كاشف الفضائح هذا هو الـــــ formula bar)

جرب هذا الملف 1-نطاق العمل من A1 الى A15 النطاق الأخضر 2- ننم القسمة على قيمة الخلية C1 واذا كانت نصاً أو فارغة تجتسب 1000 يمكن نعدبل C1 الى اي رقم تريد Time_1000.xlsm

بعد اذن الاخ علي معادلة احرى (تنسيق الخلايا Percent) =CHOOSE((S3="")+1,CHOOSE(OR(S3="وليد ",S3="سعيد")+1,0.14,0.1),"")

جرب هذا الكود Option Explicit Sub Separet_values() Dim Cel As Range Dim m%, st1, st2, My_val Range("E1").CurrentRegion.ClearContents For Each Cel In Range("A1").CurrentRegion.Cells m = Cel.Row If Cel.MergeCells Then st1 = Cel.MergeArea.Columns(1) st2 = Cel.MergeArea.Columns(2) My_val = IIf(IsEmpty(st1), st2, st1) Cells(m, "E") = My_val End If Next Cel End Sub الملف مرفق reda23.xlsm

جربي هذا الكود لمعرفة أرقام كل الألوان Option Explicit Sub get_colore_index() Dim i Cells(1, 1) = "Color Index" Cells(1, 2) = "Color" For i = 2 To 57 With Cells(i, 1) .Value = i - 1 .Offset(, 1).Interior.ColorIndex = i - 1 End With Next End Sub

هذه الصورة توضح الأمر

تم العمل كما تريدين بعد التعديل على الكود Yara_One _more_color.xlsb

تعدبل في الكود

أضيفى الى القائمة المنسدلة الرقم 55

اذا كان هذا العمل كبير 6000 الف قيد لجميع الأفضل عمله على الاكسس(برنامج مخصص Data Base) لا الأكسل

تعدبل الكود Option Explicit Dim M As Worksheet Dim Act_sh As Worksheet Dim i%, Lr%, Max_ro%, rows_count% '+++++++++++++++++++++++++++++++++++ Sub test() Dim Bol As Boolean Lr = Sheets("Main").Cells(Rows.Count, 3).End(3).Row If Lr < 12 Then Exit Sub Application.DisplayAlerts = False Sheets("Modul").Visible = True For i = 12 To Lr Bol = WorksheetExists(Sheets("Main").Cells(i, 3)) If Not Bol Then Sheets("Modul").Copy after:=Sheets(Sheets.Count) ActiveSheet.Name = Sheets("Main").Range("C" & i) End If Next Sheets("Modul").Visible = 2 Sheets("Main").Select Application.DisplayAlerts = True End Sub '++++++++++++++++++++++++++++++++ Function WorksheetExists(ByVal WorksheetName As String) As Boolean Dim Sht As Worksheet For Each Sht In ThisWorkbook.Worksheets If Application.Proper(Sht.Name) = Application.Proper(WorksheetName) Then WorksheetExists = True Exit Function End If Next Sht WorksheetExists = False End Function '""""""""""""""""""""""""""""""" Sub Transfer_data_New() test Dim x Set M = Sheets("Main") If Lr < 12 Then Exit Sub For i = 12 To Lr Set Act_sh = Sheets(M.Range("C" & i) & "") Max_ro = Act_sh.Cells(Rows.Count, 3).End(3).Row + 1 If Max_ro < 12 Then Max_ro = 12 Act_sh.Cells(Max_ro, 2).Resize(, 11).Value = _ M.Cells(i, 2).Resize(, 11).Value '======================================== Act_sh.Range("B12:L" & Max_ro).RemoveDuplicates _ Columns:=Array(1, 2, 3, 4, 5, 6, _ 7, 8, 9, 10, 11), Header:=xlNo rows_count = Act_sh.Range("B12").CurrentRegion.Rows.Count If Act_sh.Range("B12") <> vbNullString Then Act_sh.Range("A12").Resize(rows_count).Value = _ Evaluate("Row(1:" & rows_count & ")") M.Range("a12:k12").Copy With Act_sh.Range("A12").CurrentRegion .PasteSpecial (xlPasteFormats) .Columns(12).EntireColumn.Delete End With End If Next End Sub yasser_w Format.xlsm

1- حذرت كثيراً من الخلايا (او الصفوف ) المدمجة و لكن لا حياة لمن تنادي لذلك قمت بادراج صف فارغ (الصف رقم 11) يرجى عدم المساس به اي تركه فارغاً دون كنابة اي شيء فيه) والأفضل اخفاؤه 2-تم ادراج صفحة باسم "Modul"مخفية وتحتوي على الجدول الأساسي قارغاً (لنسخه في حال اضافة شيتات جديدة) 3- في حال اضافة اسم اي شيت (في العامود C من الضفخة Main ابتداء من الصف 12) غير موجودة في المصنف تتم اضاقتها اوتوماتيكياً 4-تنقل البيانات بدون تكرار كل بيان الى صفحته الحاصة مع الترقيم الأوتوماتيكي الكود Option Explicit Dim M As Worksheet Dim Act_sh As Worksheet Dim i%, Lr%, Max_ro%, rows_count% '+++++++++++++++++++++++++++++++++++ Sub test() Dim Bol As Boolean Lr = Sheets("Main").Cells(Rows.Count, 3).End(3).Row If Lr < 12 Then Exit Sub Application.DisplayAlerts = False Sheets("Modul").Visible = True For i = 12 To Lr Bol = WorksheetExists(Sheets("Main").Cells(i, 3)) If Not Bol Then Sheets("Modul").Copy after:=Sheets(Sheets.Count) ActiveSheet.Name = Sheets("Main").Range("C" & i) End If Next Sheets("Modul").Visible = 2 Sheets("Main").Select Application.DisplayAlerts = True End Sub '++++++++++++++++++++++++++++++++ Function WorksheetExists(ByVal WorksheetName As String) As Boolean Dim Sht As Worksheet For Each Sht In ThisWorkbook.Worksheets If Application.Proper(Sht.Name) = Application.Proper(WorksheetName) Then WorksheetExists = True Exit Function End If Next Sht WorksheetExists = False End Function '""""""""""""""""""""""""""""""" Sub Transfer_data() test Dim x Set M = Sheets("Main") If Lr < 12 Then Exit Sub For i = 12 To Lr Set Act_sh = Sheets(M.Range("C" & i) & "") Max_ro = Act_sh.Cells(Rows.Count, 3).End(3).Row + 1 If Max_ro < 12 Then Max_ro = 12 Act_sh.Cells(Max_ro, 2).Resize(, 11).Value = _ M.Cells(i, 2).Resize(, 11).Value '======================================== Act_sh.Range("B12:L" & Max_ro).RemoveDuplicates _ Columns:=Array(1, 2, 3, 4, 5, 6, _ 7, 8, 9, 10, 11), Header:=xlNo rows_count = Act_sh.Range("B12").CurrentRegion.Rows.Count If Act_sh.Range("B12") <> vbNullString Then Act_sh.Range("A12").Resize(rows_count).Value = _ Evaluate("Row(1:" & rows_count & ")") With Act_sh.Range("A12").CurrentRegion .Borders.LineStyle = 1 .Font.Size = 14 .Font.Bold = True .Columns(1).HorizontalAlignment = xlCenter End With End If Next End Sub الملف للتجربة وابداء الرأي yasser_w.xlsm

ممكن ان تستعين بهذا الملف صفحة (Finish) nany4mg_Final.xlsm

لا أعمل على جداول فارغة وليس من واجبي تعبئة بيانات ولو كانت عشوائية كما فعلت سابقاً تفضل املأ الجدول ببعض الاسماء والبيانات 20 اسم وليس 400)

با صديقي الاسماء والمعادلا ت يجب ان توضع في sheet2 فقط والماكرو يقوم بنقل المطلوب الى بفية الشيتات (بالسبة للمعادلات ينقل نتائجها فقط) اذ لا حاجة لكتابتها مرة اخرى في كل صفحة لذلك 1- أضف الاسماء التي تريد في sheet2 مع البيانات التي تخصها 2-اسجب المعادلات (في sheet2 ) كل واحدة من الصف الاول الى اخر صف فيه داتا (أو أكثر كما تريد) 4- نفّذ الماكرو هذا مثال (مرفق الملف) عما أقصده (1100 اسم وهمي ) مع المعادلات في sheet2 فقط ملاحظة: تم التعديل على المعادلات بجيث لا تظهر الأخطاء ولا الأصفار (الق نظرة عليها في sheet2) انسخ الاسماء الحقيقية من ملفك مكان الاسماء الوهمية أو انسخ الكود الى ملفك بعد ادراج الصفحات اللازمة بنفس الأسماء ( Acounting / JobList / Sale ) ولا تنس تسمية الشيت الأساسي بـــ sheet2 nany4mg_1100.xlsm

قم باضافة ما تريد والماكرو يعرف عمله على أكمل وجه(الشرط الوحيد دون صفوف فارغة)

و هذا ما يقوم به الكود 1-فقط ضغي مكان الــ A1 النطاق حيث تبدأ البيانات 2 نفذي الكود 3 اذهبي الى Print Preview و شاهدي بنفسك

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

هذا الماكرو بكفي اذا كانت الدانا تبدأ من الـــ A1 Sub Exacte_Pr_AR() ActiveSheet.PageSetup.PrintArea = _ Range("A1").CurrentRegion.Address End Sub

في المرة الفادنة 1- رفع ملف ضغير لا يتجاوز 50 صف لأن الماكرو الذي بعمل على صف واحد يمكنه العمل على الألوف منها 2-رفع ملف يحتوي على جدول كامل (كان هناك في الجدول بيانات ناقصة كثيرة وقد قمت بادراج بيانات عشوائيه ) 3- يتم توزيع الموظفين على 3 صفخات مع الاسماء مرتبة ابجدياً ( Acounting / JobList / Sale ) جرب هذا الماكرو Option Explicit Sub filter_and_sort() Dim Sh2 As Worksheet Dim My_sh As Worksheet Dim Rg As Range Dim cret$ With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Set Sh2 = Sheets("sheet2") Set Rg = Sh2.Range("A1").CurrentRegion If Sh2.AutoFilterMode Then Rg.AutoFilter For Each My_sh In Sheets Select Case True Case My_sh.Name = "Acounting" cret = "ادارة الحاسب" Case My_sh.Name = "JobList" cret = "ادارة شئون العاملين" Case My_sh.Name = "Sale" cret = "ادارة المبيعات" Case Else GoTo Next_sh End Select My_sh.Range("A1").CurrentRegion.Clear Rg.AutoFilter 3, cret Rg.SpecialCells(12).Copy With My_sh.Range("A1") .PasteSpecial (8) .PasteSpecial (12) End With With My_sh.Range("A1").CurrentRegion .Sort Key1:=.Cells(1, 2), Header:=1 .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14 .Font.Bold = True .Rows(1).HorizontalAlignment = 3 End With Next_sh: Next If Sh2.AutoFilterMode Then Rg.AutoFilter With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .CutCopyMode = False End With Sh2.Select End Sub nany4mg.xlsm

يمكن العمل على شيت محمي بواسطة الكود دون ازالة الحمابة باستعمال هذا السطر (اذا كانت الشيت Sheet1 هي الشيت المحمبة) Sheets("Sheet1").Protect , UserInterFaceOnly:=True هذا مثال عما اقصده النطاق الأصفر في هذا الملف محمي بدون كلمة سر الكود Option Explicit Sub test() Dim i% Sheets("Sheet1").Protect , UserInterFaceOnly:=True For i = 1 To 10 Sheets("Sheet1").Range("A" & i) = i * 10 Next End Sub الملف مرفق للمعاينة Prot_sheet.xlsm