سليم حاصبيا

شاهد هذا الفيديو (هناك 7 طرق) https://www.youtube.com/watch?v=MhnaR823Zgo&ab_channel=GameTrick

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

للمرة المائة بعد الالف استقلالية الجدول و عدم ادراج خلايا مدمجة في داخله تم ادراج صفين فارغين تماماً( 7 و 8 ) و تم اخفائهما لعدم الكتاية فيهما عن طريق الخطأ مما يؤثر سلباً على الكود الكود Option Explicit Sub Myfilter() Dim sh As Worksheet Dim Ar_Sh(), AR_comp(), I% Dim RG_Filter As Range, Ro%, K% With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Set sh = Sheets("2021-3") Set RG_Filter = sh.Range("B8").CurrentRegion If sh.AutoFilterMode Then RG_Filter.AutoFilter Ro = RG_Filter.Rows.Count AR_comp = Array("شركة", "بنك مصر", "معاش") Ar_Sh = Array("Company", "Salery", "Bank") For I = LBound(Ar_Sh) To UBound(Ar_Sh) Sheets(Ar_Sh(I)).Range("A10:R1000").Clear RG_Filter.AutoFilter 4, AR_comp(I) RG_Filter.Cells(2, 1).Resize(Ro - 1, 18) _ .SpecialCells(12).Copy With Sheets(Ar_Sh(I)).Range("A10") .PasteSpecial (8) .PasteSpecial (12) K = .CurrentRegion.Rows.Count .Offset(K) = "Sum" .Offset(K, 6).Resize(, 12).Formula = _ "=SUM(G10:G" & K + 9 & ")" .Offset(K, 6).Resize(, 12).Value = _ .Offset(K, 6).Resize(, 12).Value .Offset(K).Resize(, 18).Interior.ColorIndex = 35 With .Resize(K + 1, 18) .Borders.LineStyle = 1 .Font.Size = 14 .InsertIndent 1 End With .Offset(K).Resize(, 6).HorizontalAlignment = 7 End With Next If sh.AutoFilterMode Then RG_Filter.AutoFilter With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .CutCopyMode = False End With sh.Activate Range("g9").Select End Sub الملف مرفق Nafal.xlsm

بواسطة المعادلات لا يمكن عمل هذا الشيء لانه مجرد ان تغير الأرقام يتم مسح كل شيء من الصفحة شهري و يبقى فقط اليوم المسجل في اليومية تفيير اسماء الصفحات الى Daily و Montghly لحسن نسخ الكود ولصقة الكود Option Explicit Sub From_Daily_to_Monthly() Dim D As Worksheet, M As Worksheet Dim F_rg As Range, Find_what, RO%, n%, Answer As Byte Set D = Sheets("Daily") Set M = Sheets("Monthly") Find_what = D.Range("O4") Set F_rg = M.Range("M3:M35").Find(Find_what, lookat:=1) If F_rg Is Nothing Or Find_what = vbNullString Then MsgBox "in range " & M.Range("M3:M35").Address & Chr(10) & _ "I can't find your data " & Find_what, 64 Exit Sub End If RO = F_rg.Row n = Application.CountA(M.Range("C" & RO).Resize(, 10)) If n Then Answer = MsgBox("This data Already Exit " & Chr(10) & _ "Do you want to Replace It", vbYesNo) If Answer <> 6 Then Exit Sub End If M.Range("C" & RO).Resize(, 10).Value = _ D.Range("C6").Resize(, 10).Value End Sub dr_ahmed.xlsm

هذا الملف يقوم بادراج كل الفصول في القائمة المنسدلة اوتوماتيكياً (بدون تكرار) Ragheb.xlsm

يجب ادراج القصول التي قمت باضافتها في القائمة المنسدلة

تفضل (بعد ازالة الحلابا المدمجة) Ragheb.xlsx

جرب هذا الشيء With Sheet1.Range("F5:F34,F50:F79,F95:F124") .NumberFormat = "General" .Value = .Value End With

الخلايا المدمجة داخل الجدول (العدو الأول للأكواد والمعادلات ) تجنب استعمالها اذا كان لا بد منها يجب عزلها عن بقية الجدول بصف فارغ(يمكن اخفاءه) في الصورة مثلاً الخلية A127 مدموجة مع الخلبة B127 الخلية A128 مدموجة مع الخلبة B128 و هكذا حتى A136.. ونفس الشيء من A37 الى A46 / من A82 الى A91 الكود المطلوب بعد ازالة دمج الخلايا (الصفحة Salim من هذا الملف) Option Explicit Sub del_data() Dim Ar(), ar_Num() Dim Rg_To_copy, cel As Range Dim My_sh As Worksheet Dim Dic As Object Dim y%, k% Set My_sh = Sheets("Salim") Set Dic = CreateObject("Scripting.Dictionary") Ar = Array("B5", "B37", "B50", "B82", "B95", "B127") ar_Num = Array(30, 10, 30, 10, 30, 10) For k = LBound(Ar) To UBound(Ar) For Each cel In My_sh.Range(Ar(k)).Resize(ar_Num(k)) If Not IsEmpty(cel) Then Rg_To_copy = My_sh.Range("B" & cel.Row).Resize(, 7) Rg_To_copy = Application.Transpose(Rg_To_copy) Rg_To_copy = Application.Transpose(Rg_To_copy) Dic(Dic.Count) = Join(Rg_To_copy, "*") End If Next If Dic.Count Then My_sh.Range(Ar(k)).Resize(ar_Num(k), 7).ClearContents For y = 0 To Dic.Count - 1 My_sh.Range(Ar(k)).Offset(y).Resize(, 7).Value = _ Split(Dic.Item(y), "*") Next End If Dic.RemoveAll Next k Set Rg_To_copy = Nothing: Set cel = Nothing Set My_sh = Nothing: Set Dic = Nothing Erase Ar: Erase ar_Num End Sub الملف مرفق salim-coding.xlsm

كان يجب من البداية ادراج الملف ولا ضرورة لاضاعة الوقت Option Explicit Sub Salim_Order() Dim Mmax%, i%, x% Dim S_lst As Object Dim Txt Dim Ar(), itm Ar = Array(17, 16, 15, 14, 13, 12, 11) x = 1 Set S_lst = CreateObject("System.Collections.SortedList") With Sheets("Salim") .Range("f1").CurrentRegion.ClearContents Mmax = .Cells(Rows.Count, 1).End(3).Row For Each itm In Ar i = 1 Do Until i = Mmax + 1 If Left(.Range("A" & i), 2) = CStr(itm) Then Txt = Split(.Range("A" & i), "_") S_lst.Add CInt(Txt(2)), .Range("A" & i) End If i = i + 1 Loop For i = S_lst.Count - 1 To 0 Step -1 .Cells(x, 6) = S_lst.GetByIndex(i) x = x + 1 Next S_lst.Clear Next itm .Range("G1").Resize(x - 1).Formula = _ "=INDEX($B$1:$B$100,MATCH(F1,$A$1:$A$100,0))" .Range("F1").CurrentRegion.Value = _ .Range("F1").CurrentRegion.Value End With Set S_lst = Nothing End Sub AhMad_Assri.xlsm

يا صديقي أقل شيء يمكن ان تعمله هو رفع ملف بما تريد ولا تدع من يريد المساعدة ان ينشأ لك ملفاً بهذا الموضوع(احتراماً للوقت ليس الا) الكود المطلوب (العامود D الفرز تنازلي العامود E الفرز تصاعدي) Option Explicit Sub Salim_Order() Dim Mmax%, i%, x% Dim S_lst As Object Dim Txt Set S_lst = CreateObject("System.Collections.SortedList") With Sheets("Salim") If .Range("D1").CurrentRegion.Rows.Count > 1 Then .Range("D1").CurrentRegion.Offset(1). _ Resize(.Range("D1").CurrentRegion.Rows.Count - 1). _ ClearContents End If Mmax = .Cells(Rows.Count, 1).End(3).Row i = 2 Do Until i = Mmax + 1 If .Range("A" & i) <> vbNullString Then Txt = Split(.Range("A" & i), "_") If Not S_lst.Contains(CInt(Txt(2))) Then S_lst.Add CInt(Txt(2)), "_" & Txt(1) & "_" & Txt(0) End If End If i = i + 1 Loop x = 2 For i = S_lst.Count - 1 To 0 Step -1 Cells(x, 4) = S_lst.GetKey(i) & S_lst.GetByIndex(i) x = x + 1 Next x = 2 For i = 0 To S_lst.Count - 1 Cells(x, 5) = S_lst.GetKey(i) & S_lst.GetByIndex(i) x = x + 1 Next End With Set S_lst = Nothing End Sub الملف مرفق (اضغط فقط غلى الزر ٌRun) Assri_Ahmad.xlsm

نعديل الكود (نفس النتسيق) اكنب رؤوس الأعمدة التي تريدها في الصف رقم 8 Option Explicit Sub Form_To() Dim F As Worksheet, W As Worksheet Dim max_ro%, max_col% Set F = Sheets("From") Set W = Sheets("Where") max_ro = F.Cells(Rows.Count, 1).End(3).Row max_col = F.Cells(8, Columns.Count).End(1).Column With W.Cells(8, 1) .CurrentRegion.Clear .Offset(, 9).CurrentRegion.Clear F.Cells(8, 1).Resize(max_ro - 7).Copy .PasteSpecial F.Cells(8, 2).Resize(max_ro - 7, max_col - 1).Copy .Offset(, 9).PasteSpecial End With Application.CutCopyMode = False End Sub Naser_1.xlsm

اسماء الصفحات باللغة الأجنبية (ثم ما هذه الحجم الهائل للملف 11.5 ميغا) تم تحجيمة الى 80 كيلو فقط Option Explicit Sub Form_To() Dim F As Worksheet, W As Worksheet Dim max_ro%, max_col% Set F = Sheets("From") Set W = Sheets("Where") max_ro = F.Cells(Rows.Count, 1).End(3).Row max_col = F.Cells(8, Columns.Count).End(1).Column W.Cells(8, 1).Resize(max_ro - 7).Value = _ F.Cells(8, 1).Resize(max_ro - 7).Value W.Cells(8, "j").Resize(max_ro - 7, max_col - 1).Value = _ F.Cells(8, 2).Resize(max_ro - 7, max_col - 1).Value End Sub Naser.xlsm

نموذج لما تريد hanafy.xlsx

تم معالجة الامر ASAAD.xlsx

بعد اذن الاخ محمد عمليات الــــ Copy و الـــ Paste ترهق البرنامج دون اي فائدة (قدر الامكان الابتعاد عتها خاصة في حالة البيانات الكثيرة) Sub Distrebute_data() Dim lr As Long, M As Long Dim Sh As Worksheet, i%, x%, But_Sheet$ Dim AAM As Worksheet Set AAM = Sheets("عام") lr = AAM.Cells(Rows.Count, "A").End(xlUp).Row If lr < 3 Then Exit Sub i = 3 Do Until i = lr + 1 On Error Resume Next But_Sheet = AAM.Cells(i, "G") Set Sh = Sheets(But_Sheet) If Err.Number = 0 Then x = Sh.Cells(Rows.Count, "A").End(xlUp).Row + 1 Sh.Cells(x, 1).Resize(, 9).Value = _ AAM.Cells(i, "a").Resize(, 9).Value End If Error.Clear i = i + 1 Loop AAM.Cells(3, 1).Resize(lr, 9).ClearContents End Sub

ممكن ان يكون ما تريد في هذا الملف Abd_Aziz_2.xlsx

هناك لا نهاية من الاعداد التي تقبل القسمة على 8 ( هل هناك مجال لمعرفة بين اي عددين تريد ذلك) مثلا جميع الارقام بين 20 و 70 التي تقبل القسمة على 8 هذا مثال عما أقصده ألصفحة Salim من هذا الملف ) Mushal_1.xlsx

هذه المعادلة في I2 واسجب نزولاً =MAX(0,SUM(E2:G2)-SUM(H2)) Abd_Aziz.xlsx

جيث انك لم ترفع ملف لما تريد اليك هذا المثال Mushal.xlsx

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

هذه المعادلة =MAX(0,SUM(C5,-D5)) و اذا لم تعمل معك استبدل الفاصلة ", " بفاصلة منقوطة " ;" (حسب اعدادات الجهاز عندك) =MAX(0;SUM(C5;-D5))

جرب هذا الكود Sub add_comment() Dim ro%, i%, Txt$ With Sheets("Sheet1") ro = .Cells(Rows.Count, 1).End(3).Row .Cells(2, "D").Resize(ro - 1).ClearContents i = 2 Do While i <= ro If .Cells(i, 1) <> "" Then Select Case .Cells(i, 1).Font.ColorIndex Case 3: Txt = "Discount" Case 14: Txt = "Adding" Case Else: Txt = "" End Select .Cells(i, 4) = Txt End If i = i + 1 Loop End With End Sub Ahmedbon_1.xlsm

صديقي المعادلات لا تقوم بتغيير Format الحلية ( اللون ولون الخط او حجمه الخ...) ولا حتى تنظر الى هذا الـــ Format انها فقط نفوم بحساب محتوباتها لتغيير Format الحلية لا بد من التنسيق الشرطي او الــ VBA Option Explicit Sub Colorize_Font() Dim ro%, i% With Sheets("Sheet1") ro = .Cells(Rows.Count, 1).End(3).Row i = 2 Do While i <= ro If .Cells(i, 1) <> "" Then .Cells(i, 2).Font.Color = _ IIf(.Cells(i, 2) <> "", .Cells(i, 1).Font.Color, 0) .Cells(i, 3).Font.Color = _ IIf(.Cells(i, 3) <> "", .Cells(i, 1).Font.Color, 0) End If i = i + 1 Loop End With End Sub مرفق ملف بمعادلات اقصر Ahmedbon.xlsm

طريقة اخرى اكثر تفصيلاً الصفحة ALL_In One من هذا الملف Salwa_1.xlsm