سليم حاصبيا

معذرة لا أعمل على الخلابا المدمجة

Dim Reponse% If m <> 0 Then Reponse = MsgBox("الرقم مكرر هل تريد المتابعة: " & Chr(10) & _ Join(arr, " ; "), 524292) If Reponse <> 6 Then Exit Sub End If

تم التعديل jAZ_last.xlsm

قم بالتعديل كما في الصورة

جرب هذا الكود Option Explicit Sub colorize() Dim lr%, i% Const n = 35 Const Mot = "Saturday" With Sheets("My_sheet") lr = .Cells(Rows.Count, 1).End(3).Row .Range("A1:A" & lr).Interior.ColorIndex = xlNone For i = 1 To lr If .Cells(i, 1) = Mot Then .Cells(i, 1).Interior.ColorIndex = n End If Next End With End Sub الملف مرفق Sayaed.xlsm

الصورة توضح العمل على اليوزر يحب ترتيب الجدول (المربع الأزرق) تصاغدياً 1- بعد ان تعبئة التكس بوكس 1 و 2 وتختار النسبة اضغط على الزر GO jAZZAWI.xlsm

Try This Macro Option Explicit Dim E As Worksheet Dim O As Worksheet Dim RO%, RE%, i%, col% Dim x1%, x2%, y%, Total% Dim F_rg As Range Dim Where As Range Dim Bol As Boolean '+++++++++++++++++++++++++++++++++++ Sub Begin() Set O = Sheets("ONE") Set E = Sheets("Ehtiag") RO = O.Cells(Rows.Count, 1).End(3).Row col = E.Cells(1, Columns.Count).End(1).Column RE = E.Cells(Rows.Count, 1).End(3).Row Set Where = O.Range("J1:J" & RO) E.Range("C3").Resize(RO - 2, col - 2).Clear End Sub '+++++++++++++++++++++++++++++++++ Sub Ila_al_Amam_Ser() Application.ScreenUpdating = False Begin For i = 3 To RE Set F_rg = Where.Find(E.Range("A" & i), LOOKAT:=1) If Not F_rg Is Nothing Then x1 = F_rg.Row: x2 = x1 Do Bol = IsError(Application.Match(O.Cells(x2, 1), _ E.Cells(1, 1).Resize(, col), 0)) If Not Bol Then y = Application.Match(O.Cells(x2, 1), _ E.Cells(1, 1).Resize(, col), 0) E.Cells(i, y) = "Ok" End If Set F_rg = Where.FindNext(F_rg) x2 = F_rg.Row If x2 = x1 Then Exit Do Loop End If Next i Total = Application.CountA(E.Range("C3").Resize(RE - 2, col - 2)) If Total = 0 Then GoTo Buy_Buy With E.Range("C3").Resize(RE - 2, col - 2) .Borders.LineStyle = 1 With .SpecialCells(2, 23) .Font.Bold = True .Font.Size = 16 .InsertIndent 1 .Interior.ColorIndex = 35 End With End With Buy_Buy: Application.ScreenUpdating = True End Sub File Included happy_0.xlsm

العنوان واضح انا اتساءل اين الوضوح

جرب هذه الملف ويمكن التعديل عليه ليتناسب مع ملفك Option Explicit Dim lr% Const How_many = 10 Dim Sh As Worksheet Dim i%, k%, x '+++++++++++++++++++++++++++++++ Sub Begining() Set Sh = Sheets("Sheet1") lr = Sh.Cells(Rows.Count, 1).End(3).Row End Sub '++++++++++++++++++++++++++++++++++++ Private Sub CommandButton1_Click() Begining Dim t: t = 1 If lr < How_many + 1 Then Exit Sub x = lr - How_many + 1 With Me.ListBox1 .Clear .AddItem .List(.ListCount - 1, 0) = "Count" .List(.ListCount - 1, 1) = Sh.Cells(1, 1) .List(.ListCount - 1, 2) = Sh.Cells(1, 2) .List(.ListCount - 1, 3) = Sh.Cells(1, 3) For k = x To lr .AddItem .List(.ListCount - 1, 0) = t t = t + 1 For i = 1 To .ColumnCount - 1 .List(.ListCount - 1, i) = _ Sh.Cells(k, i) Next i Next k End With End Sub '+++++++++++++++++++++++++++++++ Private Sub UserForm_Initialize() Begining With Me.ListBox1 .AddItem .List(.ListCount - 1, 0) = "Count" .List(.ListCount - 1, 1) = Sh.Cells(1, 1) .List(.ListCount - 1, 2) = Sh.Cells(1, 2) .List(.ListCount - 1, 3) = Sh.Cells(1, 3) For k = 2 To lr .AddItem .List(.ListCount - 1, 0) = k - 1 For i = 1 To .ColumnCount - 1 .List(.ListCount - 1, i) = _ Sh.Cells(k, i) Next i Next k End With Me.CommandButton1.Caption = _ "Laste " & How_many End Sub Laste_10.xlsm

ربما يساعدك هذا الملف المعادلات المطلوبة في الأعمدة D و E (مخفية حفاظاً عليها من العيث بها عن طريق الحطأ) اكتب في الخلية (G1) حرف أو عدة جروف واضغط على سهم القائمة المنسدلة في الصفحة الأولى الاسماء حسب الحرف (الحروف) اينما وجدت في الصفحة الثانية (Salim) الاسماء حسب أول حرف(حروف) من الاسم عسى ان ينال الاعجاب harb_Drop.xlsx

في الملف الأخير تم تعديل الماكرو ليمسح البيانات القديمة (أعد تجميله) "Kara3_22.xlsm"

في اي خلية اكتب هذه المعادلة واسحب نزولاً =ABS(E4)

ما هو الموجود في الشيت "قائمة الزبائن" 5 زبائن فقط حاول اضافة زبائن اخرى و ترى النتائج كما في هذا الملف Kara3_22.xlsm

جرب هذا الماكرو Option Explicit Dim LC%, LD%, LM%, k%, i%, m% Dim last_col%, Tar_col% Dim RC As Range, RD As Range, RM As Range Dim R_date As Range, Fd1 As Range Dim Date1 As Date, Date2 As Date Dim Max_date As Date Dim Min_date As Date '+++++++++++++++++++++++++++++++++++ Sub General_Macro() Set R_date = Cap.Range("E4").Resize(, 100) last_col = Cap.Cells(4, Columns.Count).End(1).Column If last_col < 6 Then Exit Sub Min_date = 100000: Max_date = 1 For i = 6 To last_col If Cap.Cells(4, i) > Max_date Then Max_date = Cap.Cells(4, i) End If If Cap.Cells(4, i) < Min_date Then Min_date = Cap.Cells(4, i) End If Next Set RC = Cap.Range("A6").CurrentRegion LC = RC.Rows.Count Set RD = Daay.Range("A6").CurrentRegion LD = RD.Rows.Count Set RM = More.Range("A6").CurrentRegion LM = RM.Rows.Count End Sub '+++++++++++++++++++++++++++++++++++++ Sub One_day() General_Macro If last_col < 6 Then Exit Sub If Daay.Range("A6") <> "" Then Daay.Range("A6"). _ Resize(LD + 1, 6).ClearContents End If If Not IsDate(Daay.Range("b2")) Or _ Daay.Range("B2") < Min_date Or _ Daay.Range("B2") > Max_date Then Date1 = Min_date Daay.Range("B2") = Date1 End If Date1 = Daay.Range("B2") m = 6 Set Fd1 = R_date.Find(Date1, lookat:=1) If Not Fd1 Is Nothing Then Daay.Cells(4, 6) = Date1 Tar_col = Fd1.Column For k = 6 To LC + 5 If Cap.Cells(k, Tar_col) <> "" Then Daay.Cells(m, 1).Resize(, 5).Value = _ Cap.Cells(k, 1).Resize(, 5).Value Daay.Cells(m, 6) = Cap.Cells(k, Tar_col) m = m + 1 End If Next End If End Sub '+++++++++++++++++++++++++++++++++++++++ Sub More_days() General_Macro Dim X%, Periode% If last_col < 6 Then Exit Sub If More.Range("A6") <> "" Then More.Range("A6"). _ Resize(LM + 1, 6).ClearContents End If More.Cells(4, "F").Resize(, 100).ClearContents If Not IsDate(More.Range("B2")) Or _ More.Range("B2") < Min_date Or _ More.Range("B2") > Max_date Then Date1 = Min_date More.Range("B2") = Date1 End If Date1 = More.Range("D2") If Not IsDate(More.Range("D2")) Or _ More.Range("D2") < Min_date Or _ More.Range("D2") > Max_date Then Date2 = Max_date More.Range("D2") = Date2 End If Date1 = Application.Min(More.Range("B2,D2")) Date2 = Application.Max(More.Range("B2,D2")) More.Range("B2") = Date1 More.Range("D2") = Date2 Periode = Date2 - Date1 + 1 With More.Cells(4, "F") For i = 1 To Periode .Offset(, i - 1) = Date1 + i - 1 Next End With m = 6 Set Fd1 = R_date.Find(Date1, lookat:=1) If Not Fd1 Is Nothing Then Tar_col = Fd1.Column For k = 6 To LC + 5 X = Application.CountA(Cap.Cells(k, Tar_col) _ .Resize(, Periode)) If X > 0 Then More.Cells(m, 1).Resize(, 5).Value = _ Cap.Cells(k, 1).Resize(, 5).Value More.Cells(m, 6).Resize(, Periode).Value = _ Cap.Cells(k, Tar_col).Resize(, Periode).Value m = m + 1 End If Next k End If End Sub الملف مرفق Kara3_21.xlsm

لا أعلم هذا كنت نريد هذا الشيء معادلة لادراج فائمة منسدلة متحركة في الخلية E2 Harb.xlsx

بعد اذن الاخ على =INDEX($B$10:$B$39,MATCH(0,$B$10:$B$39,0)-1)

المعادلة يجب ان تكتب هكذا =IFFERROR(.................................),"") اي ان اتنتهي بــــ "" و ليس " واحدة

ليست المرة الأولى التي اقول فيها "ممنوع دمج الخلايا حيث يوجد معادلات" تم ازالة الدمج و لن اقبل بأي مشاركة فيها خلايا مدمجة و تتطلب معادلات بعد الآن الملف مرفق makl.xlsx

هذه المحاولة (الملف مرفق) zahra_Final_2.xlsm

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

هذا التعديل (تم التجربة على العامود B ) وكانت النتيجة كما تريدين 1- جدول المقارنة (قبل الماكرو وبعده ) الذي ارسلته (في النطاق L1 الى M25 ) كما تلاحظين بعد تنفيذ الماكرو (على العامود B) كل الكلمات "إخفاء " يتم اخفاء صفوفها الملف مرفق zahra_Final_1.xlsm

يجب تحديد خلية داخل الجدول قبل تنفيذ الكود لأنه اذا كانت الخلية المحددة خارج الجدول الماكرو يتحاهلها

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

تم النعديل كما تريدين Option Explicit Sub show_all() show_Columns show_rows End Sub '+++++++++++++++++++++++++++++++ Sub Hid_col() show_Columns show_rows 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 .Columns(1).Hidden = False Application.Goto .Cells(1, 1) End With Hide_row (y) End Sub '+++++++++++++++++++++++++++++++++ Sub show_Columns() Sheets("sheet1").Columns.Hidden = False End Sub '+++++++++++++++++++++++++++++++++++ Sub show_rows() Sheets("sheet1").Rows.Hidden = False End Sub '++++++++++++++++++++++++++++ Sub Hide_row(ByVal x) Dim t%, m% With Sheets("sheet1") t = .Cells(Rows.Count, x).End(3).Row For m = 3 To t Step 2 If .Cells(m, x) = 0 Or _ .Cells(m, x) = vbNullString Then .Cells(m, x).EntireRow.Hidden = True End If Next End With End Sub الملف من جديد zahra_Final.xlsm

أضف الى الكود هذا السطر (الصورة)