سليم حاصبيا

أولاً يجب عليك ان تذكر من وضع لك الكود في المشاركة التي رفعتها الكود '+++++++++++++++++++++++++++++++++++ Sub show_Col() Sheets("sheet1").Columns.Hidden = False End Sub '+++++++++++++++++++++++++++++++++++ Sub show_all() Sheets("sheet1").Rows.Hidden = False End Sub '++++++++++++++++++++++++++++ Sub hid_rows_and_columns() HideRows Hid_col End Sub Sub Show_rows_and_columns() show_Col show_all End Sub '+++++++++++++++++++++++++++++++++++ Sub HideRows() Dim Ro%, i% With Sheets("Sheet1") .Rows.Hidden = False Ro = .Cells(Rows.Count, "C").End(3).Row For i = 1 To Ro If .Cells(i, 1) = vbNullString And _ Application.Sum(.Cells(i, "d").Resize(, 7)) = 0 Then .Cells(i, 1).EntireRow.Hidden = True End If Next End With End Sub ''+++++++++++++++++++++++++++++++++++ Sub Hid_col() Dim rg As Range, y% Set rg = Selection If rg.Columns.Count > 1 Then Set rg = rg.Cells(1, 1) End If y = rg.Column If y > 7 Then Exit Sub With Sheets("Sheet1").Range("A1:G1") .Columns.Hidden = True .Columns(y).Hidden = False Application.Goto .Cells(1, y) End With End Sub الملف مرفق zahra_M.xlsm

استعمل هذه المعادلة بدل التي وضعتها لتفادي الخطأ في حال تم كتابة نص او اي شيء غير الارقام في العامودين I و J الملف مرفق من جديد marwa_New_2.xlsm

في العامود K لا يتعير شيء المعادلات تعمل في الصفحة الرئيسية و تنقل الى باقي البشيتات قيمتها فقط وذلك لتقليل حجم الملف من حيث عدد المعادلات فيه (اذ يمكن ان يتخيل الانسان 20 صفحة زيادة (حسب عدد العملاء) و في كل واحدة اكثر من 50 معادلة) فلماذا لا نجعل الاكسل يرتاح من حسابها

تم معالجة الأمر لا لزوم لادراج معادلات الا في العامود E ابتداء من الخلية E7 تم ادراج تواريخ عشوائية للتأكد من عمل الماكرو بشكل صحيح marwa_New_1.xlsm

بغض الخطوات التي يجب اتباعها قيل تنفيذ الماكرو الجدول يجب ان يكون مستقلاً غن اي خلايا لا علاقة له بها لذلك 1- تم تفريغ الصف رقم 5 من اي شيء واخفاءه (لعدم الكتابة فيه غن طريق الحطأ) 2- تم تفريغ العامودين ( D و L ) من اي شيء واخفاءهما (لعدم الكتابة فيهما غن طريق الحطأ) 3- الماكرو يأخذ بعض الوقت ليكمل عمله (جوالي 10 ثواني -- حسب سرعة الحهاز عندك) لان البيانات كثيرة جداً 4- الصفحات الأحرى موجودة لكن تم اخفائها لمتابعة عمل الماكرو (بكمن اعادة اظهارها) الكود Option Explicit Dim i%, Lr%, k% Dim Filer_Rg As Range Dim Mon_Array(), Itm '++++++++++++++++++++++++++++++++++++++++ Sub ADD_Sheet() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With With Tousi3 Lr = .Cells(Rows.Count, "H").End(3).Row If Lr < 7 Then Exit Sub For i = 7 To Lr If Application.CountIf(.Range("H2:H" & i), _ .Range("H" & i)) = 1 Then ReDim Preserve Mon_Array(k) Mon_Array(k) = .Range("H" & i) k = k + 1 End If Next For i = 7 To Lr If Not Application.Evaluate("ISREF('" & _ .Range("H" & i) & "'!A1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = _ .Range("H" & i) End If Next End With End Sub '++++++++++++++++++++++++++++++++++++++++ Sub Filter_Please() ADD_Sheet Dim Rg As Range, Ro% Tousi3.AutoFilterMode = False Set Filer_Rg = Tousi3.Range("E6").CurrentRegion For Each Itm In Mon_Array Sheets(Itm).Range("B3").CurrentRegion.Clear Filer_Rg.AutoFilter 4, Itm Filer_Rg.SpecialCells(12).Copy With Sheets(Itm).Range("B3") .PasteSpecial (8) .PasteSpecial (11) End With Set Rg = Sheets(Itm).Range("B3").CurrentRegion Ro = Rg.Rows.Count If Ro > 1 Then With Sheets(Itm).Range("A4").CurrentRegion .Cells(2, 1).Resize(Ro - 1).Value = _ Evaluate("Row(1:" & Ro - 1 & ")") .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14 .Font.Bold = True .Interior.ColorIndex = 35 .Rows(1).Interior.ColorIndex = 6 End With End If Next Tousi3.AutoFilterMode = False Tousi3.Select With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف مرفق marwa41.xlsm

يمكن عمل هذا الشيء اذا اردت من خلال كلمة سر و بدون Check Box كلمة السر في المثال Salim Fatur(NEW_1).xlsm

و كيف تظهره في حال الحاجة اليه؟؟؟ الذي يختفي هو الزر delete وليس Check Box

اضف هذين السطرين في المكان المناسب

بداية يجب ازالة الخلايا المدمجة من الملف (كي يعمل الكود بشكل صحيح) تمت الازالة الكود Option Explicit Sub Get_data() Dim LrF%, k%, LrB% Dim Arr_Form Dim Arr_to Dim Lr Arr_Form = Array("B3", "B4", "B5", "J3", "I5") Arr_to = Array(5, 6, 7, 8, 9) LrF = Fatura.Cells(Rows.Count, "B").End(3).Row - 3 LrB = Bayan.Cells(Rows.Count, "A").End(3).Row + 1 If Fatura.Cells(9, 3) = vbNullString Then Exit Sub For k = LBound(Arr_Form) To UBound(Arr_Form) Bayan.Cells(LrB, Arr_to(k)).Value = _ Fatura.Range(Arr_Form(k)).Value Next For k = 9 To LrF If Fatura.Cells(k, 3) = vbNullString Then Exit For End If Bayan.Cells(LrB, 1).Resize(, 4).Value = _ Fatura.Cells(k, 1).Resize(, 4).Value LrB = LrB + 1 Next End Sub Wael.xlsm

1-كان يجب ان تذكر من وضع لك كود الزر Detele و ذلك من باب المحافظة على الحقوق الفكرية 2-أضف الى اليورز CheckBox والكود المناسب له (كما في الصورة) 3- اذا كان الـــ CheckBox في وضعية TRUE يمكنك الجذف بعد تحديد صف في الليست بوكس 4- اذا كان الـــ CheckBox في وضعية FALSE لا يمكنك الجذف لان الزر Detele يختفي 5- في كلا الخالتين التحديد في الليست بوكس يختفي وعليك التحديد من جديد (منعاً للتسرع في حذف صف وتندم عليه) 6- الملف مرفق Fatur(NEW).xlsm

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

This Macro Sub HideRows() Dim Ro%, i% With Sheets("Sheet1") .Rows.Hidden = False Ro = .Cells(Rows.Count, "C").End(3).Row For i = 1 To Ro If .Cells(i, 1) = vbNullString And _ Application.Sum(.Cells(i, "d").Resize(, 7)) = 0 Then .Cells(i, 1).EntireRow.Hidden = True End If Next End With End Sub '+++++++++++++++++++++++++++++++++++ Sub show_all() Sheets("sheet1").Rows.Hidden = False End Sub

تمت الاجابة على هذا السؤال في مشاركة سابقة لا حاجة للماكرو يكفي ان تغير قيمة الخلية B1 لتحصل على النتيجة (مع انك ارسلت جدول فراغ و قد قمت بتعبئته ببيانات عشوائية بدل فيها ما تراه متاسباً) Adnan mushtaha.xlsx

أضف الى اليوزر زر واكتب له كود (كما في الصورة) الملف مرفق عندما تريد مسح اي بيانات حدد من الليست بوكس ما تريد حذفه ثم اضغط الزر Delete Fatur.xlsm

هذا الكود للنتسيق العامود B في الصفحة الأولى بجب ان يكون فارغاً كلياُ (تم اخفاءه لعدم الكتابة فيه غن طريق الخطأ) Option Explicit Sub My_Data_Sum() Dim Ws As Worksheet Dim Sheets_Names() Dim Client_Name() Dim m%, x%, n%, Ro%, K% Dim Rg_name As Range Dim First_All As Range, MMax% Set First_All = tak.Range("C1").CurrentRegion MMax = First_All.Rows.Count If MMax > 1 Then First_All.Offset(1).Resize(MMax).Clear End If Ro = tak.Cells(Rows.Count, 1).End(3).Row m = -1 For Each Ws In Sheets If UCase(Ws.Name) Like "SH*" Then m = m + 1 ReDim Preserve Sheets_Names(m): Sheets_Names(m) = Ws.Name End If Next Ws ' x = -1 For n = 2 To Ro If tak.Cells(n, 1) <> vbNullString Then x = x + 1 ReDim Preserve Client_Name(x) Client_Name(x) = tak.Cells(n, 1) End If Next n ' K = 2 For x = LBound(Client_Name) To UBound(Client_Name) For m = LBound(Sheets_Names) To UBound(Sheets_Names) Set Ws = Sheets(Sheets_Names(m)) Set Rg_name = Ws.Range("A:A").Find(Client_Name(x), lookat:=1) If Not Rg_name Is Nothing Then tak.Cells(K, 4).Resize(, 6).Value = _ Rg_name.Offset(1, 1).Resize(, 6).Value tak.Cells(K, 3) = Sheets_Names(m) tak.Cells(K, "J") = _ Application.Sum(tak.Cells(K, 4).Resize(, 6)) End If K = K + 1 Next m Next x If K > 2 Then With tak.Range("C2").Resize(K - 1, 8) .Borders.LineStyle = 1 .HorizontalAlignment = 3 .Font.Bold = True .Font.Size = 14 End With With tak .Cells(K, 3) = "Sum" .Cells(K, 4).Resize(, 7).Formula = _ "=SUM(D2:D" & K - 1 & ")" .Cells(K, 3).Resize(, 7) _ .Interior.ColorIndex = 40 .Cells(K, "J").Interior.ColorIndex = 3 .Cells(K, "J").Font.ColorIndex = 2 With .Range("C1").CurrentRegion .Value = .Value For x = 2 To K If .Cells(x, 1).Offset(, -2) <> "" Then .Cells(x, 1).Resize(, 8).Interior.ColorIndex = 35 End If Next End With End With End If Erase Sheets_Names: Erase Client_Name Set Rg_name = Nothing: Set First_All = Nothing Set Ws = Nothing End Sub Final_report_yara.New.xlsm

جرب هذا الماكرو Option Explicit Sub test() Dim ro1%, Ro2%, x%, y%, i% Dim t# Dim f_rg As Range Set f_rg = Range("B2:b500"). _ Find("*", LookIn:=xlValues, lookat:=1) x = 4: y = 12 If Not f_rg Is Nothing Then ro1 = f_rg.Row: Ro2 = ro1 Do For i = x To y If Ro2 = 2 Then GoTo Again t = Val(Cells(Ro2, i)) Cells(Ro2, i) = _ IIf(t > 0, -t, Cells(Ro2, i)) Next i Again: Set f_rg = Range("B2:b500").FindNext(f_rg) Ro2 = f_rg.Row If ro1 = Ro2 Then Exit Do Loop End If End Sub الملف مرفق FoMaNsHeE.xlsm

الحل هنا Option Explicit Sub My_Data_Sum() Dim Ws As Worksheet Dim Sheets_Names() Dim Client_Name() Dim m%, x%, n%, Ro%, K% Dim Rg_name As Range tak.Cells(2, 2).Resize(500, 8).ClearContents Ro = tak.Cells(Rows.Count, 1).End(3).Row m = -1 For Each Ws In Sheets If UCase(Ws.Name) Like "SH*" Then m = m + 1 ReDim Preserve Sheets_Names(m): Sheets_Names(m) = Ws.Name End If Next Ws x = -1 For n = 2 To Ro If tak.Cells(n, 1) <> vbNullString Then x = x + 1 ReDim Preserve Client_Name(x) Client_Name(x) = tak.Cells(n, 1) End If Next n K = 2 For x = LBound(Client_Name) To UBound(Client_Name) For m = LBound(Sheets_Names) To UBound(Sheets_Names) Set Ws = Sheets(Sheets_Names(m)) Set Rg_name = Ws.Range("A:A").Find(Client_Name(x), lookat:=1) If Not Rg_name Is Nothing Then tak.Cells(K, 3).Resize(, 6).Value = _ Rg_name.Offset(1, 1).Resize(, 6).Value tak.Cells(K, 2) = Sheets_Names(m) tak.Cells(K, "I") = _ Application.Sum(tak.Cells(K, 3).Resize(, 6)) End If K = K + 1 Next m Next x Erase Sheets_Names: Erase Client_Name: Set Ws = Nothing End Sub Final_repory_yara.xlsm

استبدل الرقم 19 بأي رقم تريده (حتى ولو كان 10000) لانه لا حاجة الى العامود بالكامل أكثر من مليون خلية مما يثقل البرنامج

بعد اذن الأخ حسين PrintOut ليست من خصائص الــــ Range بل هي من حصائص الـــ Sheet لذلك بهذه الطريقة تحصل على خطأ (أعنقد ذلك لكن لم اتحقق) الكود الصحيح Option Explicit Sub Print_Out() Dim lr% With ActiveSheet lr = .Cells(Rows.Count, "a").End(xlUp).Row .PageSetup.PrintArea = Range("a1:e" & lr).Address .PrintOut End With End Sub

هذه المعادلة =SUMPRODUCT((LEFT($B$5:$B$19,LEN(E5))=E5&"")*($C$5:$C$19)) sumifs_1.xlsx

لا ضرورة لهذه الكمية من الأعمدة المدمجة (الملف يجب ان يكون كما في المرفق) الكود ما يجب ان يكون Sub Print_Selection() Dim Rng As Range Dim But As Worksheet Dim Source_sh As Worksheet Dim Where As Range ScreenOff Set But = Sheets("ورقة2") Set Source_sh = Sheets("ورقة1") Set Where = But.Range("B3") But.Cells.Clear Source_sh.Select '=============================================================== Set Rng = Selection If Rng.Cells.Count = 1 Then MsgBox "Please select a range in the sheet: " & _ Source_sh.Name End If 'Rng.Interior.ColorIndex = 4 Rng.Copy Where.PasteSpecial (xlValues) Application.CutCopyMode = False 'Rng.Interior.ColorIndex = xlNone Rng = vbNullString With But .PageSetup.PrintArea = _ .Range("B3").CurrentRegion.Address .PrintPreview 'Replace by .PrintOut End With Source_sh.Select '=============================================================== ScreenOn End Sub الملف مرفق Abou_Tiba.xlsm

Try This Macro Option Explicit Sub Hide_rows() Dim Main_Rg As Range Dim cel As Range Dim Min_date As Date, Max_date As Date show_rows With Sheets("نوفمبر 2020") Min_date = Application.Min(.Range("A2:B2")) Max_date = Application.Max(.Range("A2:B2")) Set Main_Rg = .Range("A4").CurrentRegion.Offset(1).Columns(2) For Each cel In Main_Rg.Cells If cel >= Min_date And cel <= Max_date Then cel.EntireRow.Hidden = True End If Next End With End Sub '++++++++++++++++++++++++++++++++++++++ Sub show_rows() Sheets("نوفمبر 2020").Rows.Hidden = False End Sub Om_hamz_hid_rowa.xlsm

اذا كنت قد فهمت عليك ما تريده لا حاجة للكود Adnan mushtaha.xlsx

الجداول يجب ان تكون بهذا الشكل

See this video https://www.youtube.com/watch?v=IHOe5PQgIEU&ab_channel=ExcelShortcutFundas