سليم حاصبيا

ربما كان المطلوب Faris.xlsx

هذا الكود مبدئياُ من أجل القوائم المنسدلة (المترابطة) اذا لم تظهر القائمة الرئيسية في النطاق من B7 الى B31 من الصفحة (FATURA) غادر الضفجة ثم عد اليها من جديد Option Explicit Dim D As Worksheet, S As Worksheet Dim F As Worksheet Dim LrD%, LrS%, lrF% '+++++++++++++++++++++++++++++++++ Private Sub Worksheet_Activate() data_val End Sub '++++++++++++++++++++++++++++++++++++ Private Sub Worksheet_Change(ByVal Target As Range) Dim K%, t%, F_rg As Range Dim sec_arr(), mm%, y% Dim BoL As Boolean Dim Dt As Worksheet Set Dt = Sheets("DATA") Application.EnableEvents = False If Not Intersect(Target, Range("B7:B31")) Is Nothing And _ Target.Count = 1 Then If Target <> "" Then Set F_rg = Dt.Range("D1:K1").Find(Target, lookat:=1) If F_rg Is Nothing Then GoTo Fin BoL = True t = F_rg.Column mm = 2 Do Until Dt.Cells(mm, t) = "" ReDim Preserve sec_arr(1 To mm - 1) sec_arr(mm - 1) = Dt.Cells(mm, t) mm = mm + 1 Loop End If If BoL And mm > 2 Then With Target.Offset(, 1).Validation .Delete .Add 3, Formula1:=Join(sec_arr, ",") End With y = Application.RandBetween(1, mm - 2) Target.Offset(, 1) = sec_arr(y) End If End If Fin: Application.EnableEvents = True End Sub '+++++++++++++++++++++++++++++++++++++ Sub Begin() Set D = Sheets("Data") Set S = Sheets("SALES") Set F = Sheets("FATURA") LrS = S.Cells(Rows.Count, 1).End(3).Row lrF = F.Cells(Rows.Count, 2).End(3).Row End Sub '++++++++++++++++++++++++++++++++++++++++ Sub data_val() Begin Dim ro%, i%, arr() ro = D.Cells(Rows.Count, 1).End(3).Row ReDim arr(1 To ro - 1) i = 2 Do Until i = ro + 1 arr(i - 1) = D.Cells(i, 1) i = i + 1 Loop With F.Range("B7").Resize(25).Validation .Delete .Add 3, Formula1:=Join(arr, ",") End With End Sub الملف مرفق My_Bok.xlsm

زيادة في اثراء الموضوع =IF(COUNTIF(A2:C2,"غ")=3,"غ",IF(SUM(A2:C2)=0,"صفر",SUM(A2:C2))) Abscent.xls

تفضل Tarek.xlsx

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

يجعل الخلية بدون قيمة لا يوجد بها شيئ في ورقة الاكسل يوجد 1048576 ضف 16384 عامود اي 1048576× 16384 = 17179869184 خلية عن اي خلية تتكلم

حرب هذا الملف Option Explicit Sub Add_Sheets() Dim A As Worksheet Dim T As Worksheet Dim Arr_sh(), BoL As Boolean Dim ro%, X% Set A = Sheets("Aoumala") Set T = Sheets("Tempete") ro = A.Cells(Rows.Count, 2).End(3).Row If Application.CountA(A.Range("H5:H9")) < 5 Then MsgBox "Fill all Informations About The The Client" & Chr(10) & _ "In the range: " & A.Range("H5:H9").Address, 80 Exit Sub End If ReDim Arr_sh(1 To Sheets.Count) For X = 1 To Sheets.Count Arr_sh(X) = Sheets(X).Name Next BoL = IsError(Application.Match(A.Range("H6"), Arr_sh, 0)) If Not BoL Then MsgBox "This Sheet Is Already Exists" Exit Sub Else A.Range("H5:H9").Copy A.Range("A" & ro + 1).PasteSpecial Transpose:=True T.Copy After:=Sheets(Sheets.Count) With ActiveSheet .Name = A.Range("H6") .Range("D2") = .Name End With A.Select A.Range("H6:H9").ClearContents A.Range("H5") = A.Range("H5") + 1 MsgBox "That is ALL" End If End Sub Badawi.xlsm

تم التعديل كما تريد 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

جرب هذا الماكرو Sub MoveDataTOTable() Dim endrow%, n%, MAX_RO%, K% Dim M As Worksheet, D As Worksheet Set M = Sheets("Main") Set D = Sheets("DB") endrow = 1 MAX_RO = M.Range("B9").CurrentRegion.Rows.Count D.Range("A1").CurrentRegion.Offset(1).ClearContents If MAX_RO = 1 Then Exit Sub For K = 10 To MAX_RO + 10 If M.Cells(K, 2) <> "" Then n = n + 1 D.Cells(endrow + 1, 4).Resize(, 4).Value = _ M.Cells(K, 2).Resize(, 4).Value endrow = endrow + 1 End If Next If n Then With D.Cells(2, 2).Resize(n) .Value = M.Range("C6") .Offset(, 1) = M.Range("C7") .Offset(, -1) = Evaluate("Row(1:" & n & ")") End With D.Cells(2 + n, 5) = "TOTAL" D.Cells(2 + n, 7).Formula = _ "=SUM(G2:G" & n + 1 & ")" End If End Sub الملف مرفق KOUL.xlsm

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

استبدل ما هو موجود في المربع الأحمر بما هو موجود في المربع الأزرق (حسب الصورة)

استبدل ما هو موجود في المربع الأحمر بما هو موجود في المربع الأزرق (حسب الصورة)

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

Application.Visible = False لماذا اخفاء الاكسل عند فتح الملف هذه عادة سيئة انت بهذا الكود الذي وضغته في Workbook Open استعملت Application.visible=False و هذا يطبق على كل الـــ Application اي على برنامج الــ Excel بشكل عام لأنه في هذه الحالة (Application=Excel) اي شخص يدخل الى ملفك و يريد فتج ملف اخر في Excel ثانية لا يظهر له لأنه مخفي فما ذنب الذي يفتح ملفك ويفقد الاكسل , خاصة اذا كان لا يعرف كيفية اعادته للظهور

تم التعديل 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

جرب هذا الكود Private Sub btnSubmit_Click() If Me.ComboBox1 = "" Or Me.ComboBox2 = "" Then Exit Sub Dim S_rg As Range, Ro%, i% Dim Sw As Worksheet Dim BoL As Boolean Set Sw = Sheets("Sheet1") Set S_rg = Sw.Range("B2:B7") _ .Find(Me.ComboBox1.Text, lookat:=1) If S_rg Is Nothing Then Exit Sub Ro = S_rg.Row For i = 3 To 10 If Sw.Cells(Ro, i) = "" Then BoL = True Exit For End If Next If BoL Then Sw.Cells(Ro, i) = _ Me.ComboBox2.Text End Sub الملف مرفق Fauzi_User.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

الصفحة "Salim" من هذا الملف Marwa.xlsm

من باب حفظ حقوق الملكية الفكرية كان لازم بل من الواجب عليك ذكر من وضع لك الكود الذي تعمل عليه

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

جرب هذا الملف Smil.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

في صفحة مستقلة اكتب النتائج التي تتوقعها (و لا ضرورة لادراج اكثر من 200 ضف ) 15 الى 20 صف تكفي