سليم حاصبيا

تم التعديل على الماكرو لكن يجب ادراج جدول للاسعار حتى يعمل الماكرو بشكل جيد (العامود E يمكن اخفاءه اذا كنت تريد ) Private Sub Worksheet_Change(ByVal Target As Range) Rem =======>> CREATETED BY SALIM HASBAYA ON 10/8/2019 Application.EnableEvents = False Dim add_ro As Long Dim son As Long Dim Match%, cont% son = Cells(Rows.Count, "A").End(xlUp).Row Dim last_ro% If Intersect(Target, Range("A9:A" & son + 1)) Is Nothing Or _ Target.Count > 1 Then GoTo ExiT_me On Error Resume Next Match = Application.Match(Target, Sheets("sheet2").Range("A:A"), 0) If Match = 0 Then _ MsgBox " This Number Not Found": _ Target = vbNullString: GoTo ExiT_me On Error GoTo 0 cont = Application.CountIf(Sheets("Sheet1").Range("A9:A" & son), Target) If cont = 1 Then '============================= Cells(Target.Row, 2) = Sheets("sheet2").Cells(Match, 2) Cells(Target.Row, 3) = 1 '========================= Else add_ro = Application.Match(Target, Sheets("Sheet1").Range("A:A"), 0) Cells(add_ro, 3) = Cells(add_ro, 3) + 1 Target = vbNullString End If last_ro = Cells(Rows.Count, "A").End(xlUp).Row Range("D9:d" & last_ro).Formula = "=IF(N($E9)<=0,0,$E9*$C9)" ExiT_me: Application.EnableEvents = True End Sub الملف من جديد RAHARAT_NEW.xlsm

تم معالجة الامر كما تريد هناك زران واحد لجلب البيانات من الشيت Master واخر لارسالها الى الشيت Data (يمكنك اضافة اعمدة في الشيت Data قدر ما تريد ابتداء من العامود M الماكرو الاول لجلب البيانات من الشيت Master والثاني لارسالها الى الشيت Data Option Explicit Sub give_data() Rem ====>> Created By Salim hasbaya 9/8/2019 Dim x As Boolean x = IsError(Application.Match([b3], Sheets("MASTER").Range("B4:B10000"), 0)) If x Then MsgBox "This Recorde: " & [b3] & " Not Exists" & Chr(10) & _ "Please Check the value of the cell B3", , "Salim Tell Yuo" Range("Info_range") = vbNullString Exit Sub End If Dim FB4$: FB4 = _ "=INDEX(MASTER!$C$4:$C$10000,MATCH(B3,MASTER!$B$4:$B$10000,0))" Dim FB5$: FB5 = _ "=INDEX(MASTER!$N$4:$N$10000,MATCH(B3,MASTER!$B$4:$B$10000,0))" Dim FB6$: FB6 = _ "=INDEX(MASTER!$BV$4:$BV$10000,MATCH(B3,MASTER!$B$4:$B$10000,0))" Dim FB7$: FB7 = _ "=INDEX(MASTER!$BM$4:$BM$10000,MATCH(B3,MASTER!$B$4:$B$10000,0))" Dim FB8$: FB8 = _ "=INDEX(MASTER!$F$4:$F$10000,MATCH(B3,MASTER!$B$4:$B$10000,0))" '============================= Dim FD4$: FD4 = _ "=INDEX(MASTER!$E$4:$E$10000,MATCH(B3,MASTER!$B$4:$B$10000,0))" Dim FD5$: FD5 = _ "=INDEX(MASTER!$D$4:$D$10000,MATCH(B3,MASTER!$B$4:$B$10000,0))" Dim FD6$: FD6 = _ "=INDEX(MASTER!$Q$4:$Q$10000,MATCH(B3,MASTER!$B$4:$B$10000,0))" Dim FD7$: FD7 = _ "=INDEX(MASTER!$G$4:$G$10000,MATCH(B3,MASTER!$B$4:$B$10000,0))" Dim FD8$: FD8 = _ "=INDEX(MASTER!$BR$4:$BR$10000,MATCH(B3,MASTER!$B$4:$B$10000,0))" '======================== Range("b4") = Evaluate(FB4): Range("b5") = Evaluate(FB5) Range("b6") = Evaluate(FB6): Range("b7") = Evaluate(FB7) Range("b8") = Evaluate(FB8) Range("D3").FormulaArray = _ "=INDEX(Data!$E$3:$E$1000,MAX(IF(Data!$C$3:$C$10000=b3,ROW($A$3:$A$11)-2,"""")))" Range("D3").Value = Range("D3").Value: Range("D4") = Evaluate(FD4) Range("D5") = Evaluate(FD5): Range("D6") = Evaluate(FD6) Range("D7") = Evaluate(FD7): Range("D8") = Evaluate(FD8) End Sub '+++++++++++++++++++++++++++++++++++++++++++++++++++ Sub trasnfer_data() Rem ====>> Created By Salim hasbaya 9/8/2019 Macro N#2 Dim DE As Worksheet, D As Worksheet Dim My_ro%, cont%, Anser As Byte Set DE = Sheets("SALIM"): Set D = Sheets("Data") cont = Application.CountIf(D.Range("a:a"), DE.Range("b3")) If cont <> 0 Then Anser = MsgBox("this recorde is alreday exist" & Chr(10) & _ "do you want to add it??", vbYesNo) If Anser <> 6 Then Exit Sub End If My_ro = D.Cells(Rows.count, 1).End(3).Row With D .Cells(2, 1).Resize(My_ro, 64).Interior.ColorIndex = xlNone With .Range("A" & My_ro + 1) .Value = DE.[b3] .Offset(, 1) = DE.[B4]: .Offset(, 2) = DE.[B5] .Offset(, 3) = DE.[B6]: .Offset(, 4) = DE.[B7] '============================= .Offset(, 5) = DE.[B8]: .Offset(, 6) = DE.[D3] .Offset(, 7) = DE.[D4]: .Offset(, 8) = DE.[D5] .Offset(, 9) = DE.[D6]: .Offset(, 10) = DE.[D7] .Offset(, 11) = DE.[D8] '=========================== .Resize(, 12).Interior.ColorIndex = 6 End With End With ' My_data = DE.[k6] End Sub الملف مرفق من جديد My_Salary_Updated .xlsm

سبق و قلت لك لا يمكن للخلية ان تكون في نفس الوقت مصدراً للبيانات( لترحيلها الى شيت data ) ومرجعاً لاستقبال البيانات من شيت اخر لذا عليك ادراج جدول اخر مماثل (بدون معادلات ) اسفل الجدول الحالي تقوم بتعبئته بما تريد ، الجدول المستحدث يكون مصدراً للبيانات التي تنوي ترحيلها الى اي شيت تريدها

جرب هذا الماكرو Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Dim add_ro As Long Dim son As Long Dim Match, cont% son = Cells(Rows.Count, "A").End(xlUp).Row If Intersect(Target, Range("A9:A" & son + 1)) Is Nothing Or _ Target.Count > 1 Then GoTo ExiT_me On Error Resume Next Match = Application.Match(Target, Sheets("sheet2").Range("A:A"), 0) If Match = 0 Then Target = vbNullString: GoTo ExiT_me On Error GoTo 0 cont = Application.CountIf(Sheets("sheet1").Range("A9:A" & son), Target) If cont = 1 Then '============================= Cells(Target.Row, 2) = Sheets("sheet2").Cells(Match, 2) Cells(Target.Row, 3) = Sheets("sheet2").Cells(Match, 3) '========================= Else add_ro = Application.Match(Target, Sheets("sheet1").Range("A:A"), 0) Cells(add_ro, 3) = Cells(add_ro, 3) + Sheets("sheet2").Cells(Match, 3) Target = vbNullString End If ExiT_me: Application.EnableEvents = True End Sub الملف مرفق RAHARAT.xlsm

هكذا يجب ان يكون جدولك (الصفحة SALIM من هذا الملف) ليقوم اي كود او معادلة بعمله على اكمل وجه كما تلاحظ ان حجم الملف انخفض من 1.17 ميغا الى 40 كيلو فقط اي حوالي 30 مرة الملف مرفق للتعديل عليه لاجراء ما يلزم My_Salary_New .xlsm

صديقي الملف الذي تعمل عليه يظهر بهذا الشكل (بعد ازالة نتسيقاته للنظر فيه عن قرب) كل الذي تحتاجه 5 او 6 اعمدة للعمل عليها (ليس من العامود الاول الى العامود AA) ما الفائدة مثلاً من دمج الخلايا من K حتى Ab لكتابة كلمة SHANKILAND (يكفي وضع هذه الكلمة في الخلية K مع توسيع العامود حسب ما تريد) كيف تريد العمل على هكذا ملف الذي يحتوي على مئات الخلايا المدمجة التي تعيق عمل اي دالة او كود

بعد اذن اخي علي معادلة بشكل ثاني =CHOOSE(AND(C1=D1,C1<>"",D1<>"")+1,"غير متزن","متزن")

Option Explicit Sub TEST() Dim X, A, B, C, I% X = Range("B3").MergeArea.Rows.Count A = Range("A3").Value B = Range("B3").Value: C = Range("C3").Value Range("A3:C3").UnMerge With Range("A3") For I = 1 To X - 1 .Offset(I, 0) = A: .Offset(I, 1) = B Next End With End Sub جرب هذا الماكرو

هذه المعادلة في العامود الأخير =IF(COUNTIF($W2:$X2,"<>0")<=1,0,$X2-$W2) اذا لم تعمل استبدل الفاصلة " ," بفاصلة منقوطة "; " (حسب اعدادات الجهاز عندك) لتبدو المعادلة بهذا الشكل =IF(COUNTIF($W2:$X2;"<>0")<=1;0;$X2-$W2)

يمكنك تجربة هذا الملف Hide_sheets.xlsm

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

اذا كان هذا المطلوب اضغط افضل اجابة لاغلاق الموضوع

الصفحة salim من هذا الملف compaire.xlsx

لعل هذا ما تريد moukarar.xlsx

لا يجب ان يكون هناك فراغات في الجدول الاساسي

هذا الماكرو Option Explicit Sub Date_To_Text() Range("c1").CurrentRegion.ClearContents Dim cel As Range Range("a1").CurrentRegion.Offset(, 2) _ .Formula = "=TEXT(A1,""yyy/m/d"")" For Each cel In Range("c1").CurrentRegion cel.Value = "'" & cel.Value Next End Sub الملف مرفق Text_date.xlsm

اكتب في الخلية هذه المعادلة (لاحاجة للكود) =TEXT(A1,"yyy/mm/dd") or =TEXT(A1;"yyy/mm/dd")

الحل الرابع بواسطة هذه المعادلة (Ctrl+Shift+Enter) =IF($A2="","",SUM(INDEX(G_H!$D$2:$N$200,0,MATCH(D$1,G_H!$D$1:$N$1,0))*(G_H!$A$2:$A$200=$A2))) Or =IF($A2="";"";SUM(INDEX(G_H!$D$2:$N$200;0;MATCH(D$1;G_H!$D$1:$N$1;0))*(G_H!$A$2:$A$200=$A2))) اختر فاصلة أو فاصلة منقوطة للمعادلة حسب اعدادات الـــ Office عندك

بعد اذن اخي بن علية ثلاث حلول في 3 صفحات (تم تغيير الاسماء واختصار البيانات للتدقيق في صحة المعادلات) هناك حسب ما اعتقد حل رابع لم استطع معالجته لضيق الوقت اختر ما يناسبك Takrir.xlsx

تستطيع انشاء جدولين واحد تدخل فيه المعادلات والثاني تسنعمل فيه الكود

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

لا أعلم باضبط اذا كان المطلوب rawateb.xlsx

جرب هذا الملف تستطيع اختيار الاسم من القائمة المنسدلة في الخلية ( B2 ) لتفادي الاخطاء الإملائية او المسافات الزائدة او الناقصة القائمة المنسدلة مطاطة اي انها تستجيب لاي تغير في البيانات مع ذكر المكرر مرة واحدة فقط FILTER_.xls

جرب هذا الكود Option Explicit Sub Facilite_table() Dim i%, col%, R%, How_many How_many = InputBox("How Many Columns Do You Want") Range("c1").CurrentRegion.ClearContents i = 1: col = 3: R = 1 Do Until Range("a" & i) = vbNullString Cells(R, col) = Range("a" & i) R = R + 1 If R > How_many Then col = col + 1: R = 1 i = i + 1 Loop Range("c1").CurrentRegion.Columns.AutoFit End Sub

ارفق من فضلك النتائج المتوقعة(يدوياً) لاني لم افهم ما تريد