سليم حاصبيا

تم تضييق الهامشين (الأعلى والأسقل) قليلاً واصيح بالامكان العمل مع 16 اسم في كل ورقة مما يوفر كمية لا باس بها من الورف (بالنسبة لـــ 40 الف اسم) حوالي 350 ورقة Ahlawi_New_16.xlsm

الماكرو المطلوب (عملية انشاء الزر اتركها لك) Option Explicit Sub Replace_S_by_Nothing() Range("A9").CurrentRegion.Replace "س", "" Range("J9:j26").Copy Range("M9").PasteSpecial (12) Application.CutCopyMode = False Range("D9").Select End Sub

لا جاجة لجماية المعادلات اذا استخدمت هذا السطر في الكود بعد ازالة كلمة Rem من أمامه لأن اامعادلات تتجول الى قيم عادية Rem Range("G11:Aj313").Value = Range("G11:Aj313").Value

للأسف فد جربت ما تريده لكن لم استطع ان أحصل على اكثر من 14 اسم على ورقة واحدة (لأن البيانات تخرج منقسمة) Ahlawi_New_14.xlsm

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

اليك الملف مع الكود fORMULA_TO VBA.xlsm

تم التعديل على الكود Sub Formula_To_Code() Range("G11:Aj313").Formula = _ "=IF(G$10=$D11,""مغادرة"",IF(AND(G$10>=$C11,G$10<=$D11-1),$E11,0))" '================ هذا السطر اختياري لتثبيت المعادلات _ ===================== والحصول على القيم فقط لتخفيف حجم الملف _ ======================= من أوله Rem اذا اردت ذلك احذف كلمة Rem Range("G11:Aj313").Value = Range("G11:Aj313").Value '================================================= End Sub

جرب هذا الكود (في حال حذف اي معادلة او العبث بها عن طريق الخطأ قم بتشغيله) Option Explicit Sub Formula_To_Code() Dim My_Str$: My_Str = """مغادرة""" Range("G11:Aj313").Formula = _ "=IF(G$10=$D11,My_Str,IF(AND(G$10>=$C11,G$10<=$D11-1),$E11,0))" '================ هذا السطر اختياري لتثبيت المعادلات _ ===================== والحصول على القيم فقط لتخفيف حجم الملف _ ======================= من أوله Rem اذا اردت ذلك احذف كلمة Rem Range("G11:Aj313").Value = Range("G11:Aj313").Value '================================================= End Sub

نفضل با سيدي Yasser.xlsm

استبدل في المعادلات الرقم 100 بأي رقم تربده

تم التعديل قليلاً على الملف من حيث الطباعة( يقوم بطباعة كل 4 بيانات على ورقة مستقلة) الطباعة ديناميكية حسب عدد البيانات Dim Source As Worksheet Dim Target As Worksheet Dim Simlpe As Worksheet Dim i%, Cunt%, Ro%, k%, Position%, m% '+++++++++++++++++++++++++++++++++ Sub debut() Set Source = Sheets("Source") Set Target = Sheets("Target") Set Simple = Sheets("Simple") End Sub '+++++++++++++++++++++++++++++++++++ Sub copy_rg(ByVal src As Worksheet, _ ByVal Tg As Worksheet, ByVal Rg_name$, ByVal Rg_where$) src.Range(Rg_name).Copy With Tg.Range(Rg_where) .PasteSpecial (xlPasteAll) .PasteSpecial (8) End With End Sub '+++++++++++++++++++++++++++++++++++++++ Sub Copy_Tables() debut Target.Cells.Clear Ro = Source.Cells(Rows.Count, 2).End(3).Row - 1 Cunt = (Ro \ 2) + 1 k = 1 For i = 1 To Cunt Call copy_rg(Sheets("Simple"), Sheets("Target"), _ "Simple_Rg", "B" & k) k = k + 7 Next Application.CutCopyMode = False End Sub '++++++++++++++++++++++++++++++ Sub fil_data() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Copy_Tables m = 1 For Position = 2 To Ro + 1 Step 2 With Source.Cells(Position, 2).Resize(, 4) .Copy Target.Cells(m, 3).PasteSpecial _ Paste:=12, Transpose:=True .Offset(1).Copy Target.Cells(m, 6).PasteSpecial _ Paste:=12, Transpose:=True End With m = m + 7 Next Print_areas With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .CutCopyMode = False End With Target.Cells(1, 2).Select End Sub '++++++++++++++++++++++++++++++++ Sub Print_areas() Dim x, Rg_last As Range, y% Dim k Sheets("target").ResetAllPageBreaks x = Sheets("target").Cells(Rows.Count, 2).End(3).Row If x < 8 Then Sheets("target").PageSetup.PrintArea = _ Sheets("target").Range("A1:F4").Address Exit Sub End If Set Rg_last = Sheets("target"). _ Range("c" & x - 1).Resize(10).Find("*") If Not Rg_last Is Nothing Then y = Rg_last.Row + 1 Else y = x - 6 End If Sheets("target").PageSetup.PrintArea = _ Sheets("target").Range("A1:F" & y).Address For k = 13 To y Step 14 Sheets("target").HPageBreaks.Add Before:=Rows(k + 1) Next End Sub الملف معدلاً Ahlawi_New.xlsm

لا علم لي بهذا الفيديو و قد شاهدته وهو مبني على نفس الفكرة (Excellent)

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

صديقي عبدالله انت هنا تتكلم عن Pivot table الذي لا شأن له بهذا الأمر ادخل الى Vba Editor في الملف الذي رفعته لكم وانظر الى الخاصية التي اشرت اليها تجدها False بدل فيها كما تريد و تجد ان السماح بادراج الصفوف او الأعمدة لا تتغير (تبفى غير مسموحة)F اذن الحل ليس كما قلت !!!!

أهلاً وسهلاً بك و بأهل مصر (الحبيبة أم الدنيا) كلها دعاؤكم للثورة اللّبنانية فقط (كما انتصرت عندكم تنتصر في وطني لبنان) هذا الماكرو (الملف مرفق ) فقط اضغط الزر "Get _Names" Dim Source As Worksheet Dim Target As Worksheet Dim Simlpe As Worksheet Dim i%, Cunt%, Ro%, k%, Position%, m% '+++++++++++++++++++++++++++++++++ Sub debut() Set Source = Sheets("Source") Set Target = Sheets("Target") Set Simple = Sheets("Simple") End Sub '+++++++++++++++++++++++++++++++++++ Sub copy_rg(ByVal src As Worksheet, _ ByVal Tg As Worksheet, ByVal Rg_name$, ByVal Rg_where$) src.Range(Rg_name).Copy With Tg.Range(Rg_where) .PasteSpecial (xlPasteAll) .PasteSpecial (8) End With End Sub '+++++++++++++++++++++++++++++++++++++++ Sub Copy_Tables() debut Target.Cells.Clear Ro = Source.Cells(Rows.Count, 2).End(3).Row - 1 Cunt = Ro \ 2 If Cunt Mod 2 = 1 Then Cunt = Cunt + 1 End If k = 1 For i = 1 To Cunt Call copy_rg(Sheets("Simple"), Sheets("Target"), _ "Simple_Rg", "B" & k) k = k + 6 Next Application.CutCopyMode = False End Sub '++++++++++++++++++++++++++++++ Sub fil_data() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Copy_Tables m = 1 For Position = 2 To Ro Step 2 With Source.Cells(Position, 2).Resize(, 4) .Copy Target.Cells(m, 3).PasteSpecial _ Paste:=12, Transpose:=True .Offset(1).Copy Target.Cells(m, 6).PasteSpecial _ Paste:=12, Transpose:=True End With m = m + 6 Next With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .CutCopyMode = False End With Target.Cells(1, 2).Select End Sub الملف مرفق Ahlawi.xlsm

مرفق ملف اخر يمنع اضافة اعمدة او صفوف ويمنع ايضاً حذفها كبفية عمل ذلك اتركها مؤقتاً "فزورة" ربما يكتشفها البعض Privent_New_Cols_Rows.xlsx

جرب هذا الملف بمنع ادراج صفوف او أعمدة (سأفكر بطريفة لمنع حذف صفوف او أعمدة) و حاول ان تعرف السر No_New_Cols_Rows.xlsx

لا يمكن العمل على صورة ارفع الملف

هذا الكود يدرج لك القوائم المنسدلة Option Explicit Sub data_val() Dim Fatura As Worksheet, Price As Worksheet Dim Dic As Object Dim lr%, i% Set Fatura = Sheets("فواتير") Set Price = Sheets("الأسعار") Set Dic = CreateObject("Scripting.Dictionary") lr = Price.Cells(Rows.Count, 1).End(3).Row i = 2 With Price Do Until i > lr If .Cells(i, 1) <> vbNullString Then Dic(.Cells(i, 1).Value) = vbNullString End If i = i + 1 Loop End With With Fatura.Cells(5, 1).Resize(15).Validation .Delete .Add 3, Formula1:=Join(Dic.keys, ",") End With End Sub الملف مرفق samihkhader.xlsm

ليس من الضروري ادراج الكثير من الصفوف يكفي نموذج بسيط (20- 30) صف Ammaro.xlsx

try this file WiAAM.xlsx

اعد تحمبل الملف من جديد لأنه ظهر هناك خطأ بسيط في معاينة الطباعة (تم اصلاحه) الخطأ يكمن في ان الطباعة تتم ابتداء من الصف السادس بينما المطلوب ان تتم ابتداء من الصف الأول وذلك باستبدال الرقم 6 بالرقم 1 قي هذا السطر Range("A6:J31").Address

تم ادراج صفحة للعمل بواسطة المعادلات " Section_1 " تم معالجة الأمر بالنسبة للطباعة الزر "Show hidden Rows" يظهر لك الصفوف المخفية (فارغة) الماكرو يظهر لك معاينة قبل الطباعة رز " معاينة الطباعة " لاستبدال الامر الى الطباعة المباشرة غير السطر (الثالث من اخر الماكرو الأول) و لا تنس كتابة النقطة قبله من PrintPreview الى PrintOut Option Explicit Sub Print_areas() Dim Mx1%, Mx2%, Mx Show_rows If ActiveSheet.Name = "main" Then Exit Sub With ActiveSheet Mx1 = Application.Max(Range("A6:A30")) + 5 Mx2 = Application.Max(Range("F6:F30")) + 5 Mx = Application.Max(Mx1, Mx2) + 1 .Range("A" & Mx & ":A" & 30).EntireRow.Hidden = True .PageSetup.PrintArea = .Range("A1:J31").Address .PrintPreview End With End Sub '++++++++++++++++++++++++++++ Sub Show_rows() If ActiveSheet.Name = "main" Then Exit Sub ActiveSheet.Range("A6:A30").EntireRow.Hidden = False End Sub الملف من جديد Abou_malak_new.xlsm

جرب هذا الماكرو تم تعديل القوائم المنسدلة في الشيت fasl و الشيت fasl2 النطاق "K1" ليتناسب مع كل الاحنمالات في الشيت main الزر All In One1 يعمل الفلترة وينقلها الى كل شيت بمفردها في الشيت fasl و الشيت fasl2 الزر استدعاء يتفذ الماكرو الخاص بكل منهما (مع الترقيم اوتوماتيكي بدون معادلات لتصغير حجم الملف من جهة و من جهة احرى لعدم العبث بالمعادلات اذا وجدت عن طربق الحطأ ) Option Explicit Private M As Worksheet Private F1 As Worksheet Private F2 As Worksheet Private LM%, LF1%, LF2% Private M_rg As Range, F1_rg As Range Private F2_rg As Range Private Filter_range As Range Private Cret1$, Cret2$ Private cont Private y% '++++++++++++++++++++++++++++++ Sub Get_all() My_filter_forF1 My_filter_forF2 End Sub Sub My_filter_forF1() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With First_Macro On Error Resume Next F1.Range("A6:J30").ClearContents Set Filter_range = F1.Range("k1") If M.AutoFilterMode Then M.Range("A3").AutoFilter M_rg.AutoFilter 5, Filter_range M_rg.AutoFilter 7, Cret1 M.Range("B4:B" & LM).SpecialCells(12).Copy F1.Range("B6").PasteSpecial (12) M.Range("G4:G" & LM).SpecialCells(12).Copy F1.Range("C6").PasteSpecial (12) M.Range("H4:H" & LM).SpecialCells(12).Copy F1.Range("D6").PasteSpecial (12) M.Range("I4:I" & LM).SpecialCells(12).Copy F1.Range("E6").PasteSpecial (12) cont = Application.CountA(F1.Range("B6:B25")) If cont > 0 Then F1.Range("A6").Resize(cont) = _ Evaluate("ROW(1:" & cont & ")") End If M_rg.AutoFilter 7, Cret2 M.Range("B4:B" & LM).SpecialCells(12).Copy F1.Range("G6").PasteSpecial (12) M.Range("G4:G" & LM).SpecialCells(12).Copy F1.Range("H6").PasteSpecial (12) M.Range("H4:H" & LM).SpecialCells(12).Copy F1.Range("I6").PasteSpecial (12) M.Range("I4:I" & LM).SpecialCells(12).Copy F1.Range("J6").PasteSpecial (12) cont = Application.CountA(F1.Range("G6:G25")) If cont > 0 Then F1.Range("F6").Resize(cont) = _ Evaluate("ROW(1:" & cont & ")") End If If M.AutoFilterMode Then M.Range("A3").AutoFilter On Error GoTo 0 With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub '+++++++++++++++++++++++++++++++++++++ Sub My_filter_forF2() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With First_Macro On Error Resume Next F2.Range("A6:J30").ClearContents Set Filter_range = F2.Range("k1") If M.AutoFilterMode Then M.Range("A3").AutoFilter M_rg.AutoFilter 5, Filter_range M_rg.AutoFilter 7, Cret1 M.Range("B4:B" & LM).SpecialCells(12).Copy F2.Range("B6").PasteSpecial (12) M.Range("G4:G" & LM).SpecialCells(12).Copy F2.Range("C6").PasteSpecial (12) M.Range("H4:H" & LM).SpecialCells(12).Copy F2.Range("D6").PasteSpecial (12) M.Range("I4:I" & LM).SpecialCells(12).Copy F2.Range("E6").PasteSpecial (12) cont = Application.CountA(F2.Range("B6:B25")) If cont > 0 Then F2.Range("A6").Resize(cont) = _ Evaluate("ROW(1:" & cont & ")") End If M_rg.AutoFilter 7, Cret2 M.Range("B4:B" & LM).SpecialCells(12).Copy F2.Range("G6").PasteSpecial (12) M.Range("G4:G" & LM).SpecialCells(12).Copy F2.Range("H6").PasteSpecial (12) M.Range("H4:H" & LM).SpecialCells(12).Copy F2.Range("I6").PasteSpecial (12) M.Range("I4:I" & LM).SpecialCells(12).Copy F2.Range("J6").PasteSpecial (12) cont = Application.CountA(F2.Range("G6:G25")) If cont > 0 Then F2.Range("F6").Resize(cont) = _ Evaluate("ROW(1:" & cont & ")") End If If M.AutoFilterMode Then M.Range("A3").AutoFilter On Error GoTo 0 With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub ''++++++++++++++++++++++++++++++ Sub First_Macro() Set M = Sheets("main") Set F1 = Sheets("fasl") Set F2 = Sheets("fasl2") LM = M.Cells(Rows.Count, 2).End(3).Row LF1 = F1.Cells(Rows.Count, 1).End(3).Row If LF1 < 6 Then LF1 = 6 LF2 = F2.Cells(Rows.Count, 1).End(3).Row If LF2 < 6 Then LF2 = 6 Set M_rg = M.Range("A3:I" & LM) Set F1_rg = F1.Range("A6:J30") Set F2_rg = F2.Range("A6:J30") Cret1 = "ذكر": Cret2 = "أنثى" End Sub الملف مرفق Abou_malak.xlsm

تفضل با صديقي AB_Shraf.xlsm