سليم حاصبيا

تم التعديل كما تريد
Option Explicit Sub Data_Without_Empty() Dim endrow%, n%, MAX_RO%, K% Dim M As Worksheet, D As Worksheet Dim Fixed_row%, New_ro% Set M = Sheets("Main") Set D = Sheets("DB") endrow = D.Cells(Rows.Count, "E").End(3).Row Fixed_row = endrow + 1 MAX_RO = M.Range("B9").CurrentRegion.Rows.Count If MAX_RO = 1 Then Exit Sub For K = 10 To MAX_RO + 7 If M.Cells(K, 2) <> "" Then n = n + 1 D.Cells(endrow + 1, 5).Resize(, 4).Value = _ M.Cells(K, 2).Resize(, 4).Value endrow = endrow + 1 End If Next If n Then With D.Cells(Fixed_row, 3).Resize(n) .Value = M.Range("C6") .Offset(, 1) = M.Range("C7") .Offset(, 6) = M.Range("C25") .Offset(, -1) = Evaluate("Row(1:" & n & ")") End With D.Cells(n + Fixed_row, 5) = "TOTAL" D.Cells(n + Fixed_row, 8).Formula = _ "=SUM(H" & Fixed_row & ":H" & Fixed_row + n - 1 & ")" New_ro = D.Cells(Rows.Count, 2).End(3).Row D.Cells(2, 1).Resize(New_ro - 1).Formula = _ "=IF(B2="""","""",MAX($A$1:A1)+1)" D.Cells(1, 1).CurrentRegion.Value = _ D.Cells(1, 1).CurrentRegion.Value End If End Sub الملف من جديد
KOUL _1.xlsm

استعمل هذه المعادلة (في حال اضافة أو حذف أعمدة تتجدّث اوتوماتبكياً)
=SUMPRODUCT($B$2:$F$2,B3:F3) الملف مرفق
gaber.xlsx

لا حاجة في عملك الى يوزر من عدة  Multipage
1 اختر الصفحة المطلوبة من خلال الـــ Option Button
2- أملا البيانات المطلوبة
3- اضغط على الزر To Sheet (حسب هذه الصورة)
الملف مرفق

 
ghpryal2010_User.xlsm

تم التعديل
Private Sub btnSubmit_Click() If Me.ComboBox1 = "" Or Me.ComboBox2 = "" Then Exit Sub Dim S_rg As Range, Col%, i% Dim Sw As Worksheet Dim BoL As Boolean Dim last% Set Sw = Sheets("Sheet1") last = Sw.Cells(Rows.Count, 1).End(3).Row Set S_rg = Sw.Range("C2:L2") _ .Find(Me.ComboBox1.Text, lookat:=1) If S_rg Is Nothing Then Exit Sub Col = S_rg.Column For i = 3 To last If Sw.Cells(i, Col) = "" Then BoL = True Exit For End If Next If BoL Then Sw.Cells(i, Col) = _ Me.ComboBox2.Text End Sub  
Fauzi_User_vertical.xlsm

جرب هذا الملف
Option Explicit Sub Show_hide() Dim S As Worksheet Dim i%, Ro% Set S = Sheets("Salim") With S Ro = .Cells(Rows.Count, 1).End(3).Row .Range("B1").Resize(, 17) _ .EntireColumn.Hidden = False For i = 2 To 16 Step 2 If .Cells(3, i) = vbNullString Then .Cells(3, i).Resize(, 2) _ .EntireColumn.Hidden = True End If Next .PageSetup.PrintArea = _ .Range("A2").Resize(Ro-1, 17).Address .PrintPreview End With End Sub '+++++++++++++++++++++++++++++++++++++++++++++ Sub show_Al_Col() Sheets("Salim").Range("B:Q").EntireColumn.Hidden = False End Sub الملف مرفق
Fathi.xlsm

جرب هذا الملف (كل أيام الاحاد بلون /كل أيام الاثنين بلون آخر  ..... وهكذا)
amrhosny.xlsx

جرب هذا الكود
Option Explicit Sub Split_cel() Dim i%, k%, St, mot, t% With Sheets("Sheet1") .Range("C2").CurrentRegion.ClearContents i = 2 Do Until .Cells(i, 1) = vbNullString mot = Trim(.Cells(i, 1)) St = Split(mot) For k = 0 To UBound(St) If St(k) <> vbNullString Then .Cells(i, 3).Offset(, t) = St(k) t = t + 1 End If Next t = 0 i = i + 1 Loop End With End Sub الملف مرفق
Hakim.xlsm

جرب هذا الملف (مع الكود المطلوب)
Option Explicit Dim sh As Worksheet Dim ObjA As Object Dim ObjB As Object Dim Ro% '+++++++++++++++++++++++++++++ Sub Show_User() UserForm1.Show 0 End Sub '++++++++++++++++++++++++++++ Sub Debut() Set sh = Sheets("Sheet1") Set ObjA = CreateObject("Scripting.Dictionary") Set ObjB = CreateObject("Scripting.Dictionary") Ro = sh.Cells(Rows.Count, 1).End(3).Row End Sub Sub Fil_ComB_1() Debut Dim i For i = 2 To Ro ObjA(sh.Cells(i, 1).Value) = vbNullString Next With UserForm1.ComboBox1 .List = ObjA.keys: .Value = ObjA.keys()(0) End With End Sub '+++++++++++++++++++++++++++++++++++++ Sub Fil_ComB_2() Debut Dim k If UserForm1.ComboBox1.Value = vbNullString Then Exit Sub For k = 2 To Ro If sh.Cells(k, 1) = UserForm1.ComboBox1.Value Then ObjB(sh.Cells(k, 2).Value) = vbNullString End If Next If ObjB.Count Then With UserForm1.ComboBox2 .List = ObjB.keys: .Value = ObjB.keys()(0) .SetFocus End With End If End Sub الملف مرفق
Mhd_2021.xlsm

ربما تحناح الى هذا الملف (النتيجة في الصفحة ALL)
Sub Filter_All() Dim sh As Worksheet Dim A As Worksheet Dim AR_comp() Dim Ro%, K%, x%, t%, I% With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Set sh = Sheets("2021-3") Set A = Sheets("ALL") Set RG_Filter = sh.Range("B8").CurrentRegion If sh.AutoFilterMode Then RG_Filter.AutoFilter A.Range("A10:R1000").Clear Ro = RG_Filter.Rows.Count AR_comp = Array("شركة", "بنك مصر", "معاش") t = 10 For I = LBound(AR_comp) To UBound(AR_comp) RG_Filter.AutoFilter 4, AR_comp(I) RG_Filter.Cells(2, 1).Resize(Ro - 1, 18) _ .SpecialCells(12).Copy With A .Range("A" & t).PasteSpecial (8) .Range("A" & t).PasteSpecial (12) x = _ .Cells(Rows.Count, 1).End(3).Row + 1 .Cells(x, 1) = "Sum" .Cells(x, "G").Resize(, 12).Formula = _ "=SUM(G" & t & ":G" & x - 1 & ")" .Cells(x, 1).Resize(, 6).HorizontalAlignment = 7 .Cells(x, 1).Resize(, 18).Interior.ColorIndex = 35 t = x + 1 End With Next I If t = 10 Then GoTo End_me With A.Cells(t, 1) .Value = "TOTAL SUM :" .Resize(, 6).HorizontalAlignment = 7 .Resize(, 18).Interior.ColorIndex = 40 .Offset(, 6).Resize(, 12).Formula = _ "=SUM(G10:G" & t - 1 & ")/2" End With With A.Range("A10").CurrentRegion .Borders.LineStyle = 1 .Font.Size = 14 .Font.Bold = True .Value = .Value End With End_me: If sh.AutoFilterMode Then RG_Filter.AutoFilter With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .CutCopyMode = False End With A.Activate Range("A10").Select End Sub الملف مرفق
Nafal_1.xlsm

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

بواسطة المعادلات لا يمكن عمل هذا الشيء لانه مجرد ان تغير الأرقام يتم مسح كل شيء من الصفحة شهري و يبقى فقط اليوم المسجل في اليومية
تفيير اسماء الصفحات الى 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

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

كان يجب من البداية  ادراج الملف ولا ضرورة لاضاعة الوقت
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

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

نموذج لما تريد
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  

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

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

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

العامود الأخضر من هذا الملف
Abd_Date.xlsx

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

مع اني لا أحب اليوزر فورم ولا أطيق التعامل معه
بالاضافة الى اني لا أحب تسمية الاوراق ياللغة العربية(Youmia)
الكود من اليوزر االى الشيت
 
Dim Y As Worksheet Dim Arr_From() Dim Arr_To() Dim Ar_range() '++++++++++++++++++++++++++++++++++++++++++++++ Private Sub cmd_toSheet_Click() Dim i%, How_many%, Bool As Boolean Dim k% Set Y = Sheets("Youmia") Ar_range = Array("B8", "B47", "B86") Arr_From = Array("TB", "TC", "TD" _ , "TE", "TG", "TF", "TH") Arr_To = Array("B", "C", "D", _ "E", "G", "F", "H") ' For i = LBound(Arr_From) To UBound(Arr_From) ' Me.Controls(Arr_From(i)) = Chr(Application.RandBetween(65, 90)) ' Next For i = LBound(Arr_From) To UBound(Arr_From) If Me.Controls(Arr_From(i)) = vbNullString Then MsgBox "Empty TextBox " Exit Sub End If Next For i = 0 To 2 How_many = Application.CountA(Y.Range(Ar_range(i)).Resize(30)) Bool = IIf(How_many = 30, True, False) If Not Bool Then Exit For Next With Y.Range(Ar_range(i)).Cells(1).Offset(How_many) For k = LBound(Arr_From) To UBound(Arr_From) .Offset(, k) = Me.Controls(Arr_From(k)) Next End With End Sub  
Osama_User.xlsm

ربما ينفع هذا الماكرو
Option Explicit Sub My_macro() Dim D As Worksheet, RO_A%, i%, m% Dim T As Worksheet Dim arr(), it, MX, Cret, ky Dim Dic As Object Set D = Sheets("DATA") Set T = Sheets("TEST") RO_A = D.Cells(Rows.Count, 1).End(3).Row arr = Array("A", "B", "C") For Each it In arr Set Dic = CreateObject("Scripting.Dictionary") For i = 2 To RO_A If D.Cells(i, 1) = it Then Dic(D.Cells(i, 4).Value) = _ Dic(D.Cells(i, 4).Value) + Val(D.Cells(i, 3)) End If Next i MX = Application.Max(Dic.Items) For Each ky In Dic.Keys If Dic.Item(ky) = MX Then Cret = ky Exit For End If Next ky T.Cells(m + 2, "E") = Cret m = m + 1 Dic.RemoveAll Next it Set D = Nothing: Set T = Nothing Erase arr: Set Dic = Nothing End Sub الملف مرفق
Hashem_Dict.xlsm