سليم حاصبيا

جرب هذا الكود Private Sub CommandButton1_Click() Me.TextBox1.Value = "G" & _ Evaluate("=MAX(IF(ISNUMBER(--(SUBSTITUTE($A$2:$A$100,""G"",""""))),--(SUBSTITUTE($A$2:$A$100,""G"","""")),0))") + 1 End Sub الملف مرفق Max.xlsm

يمكن استعمال هذا الكود Option Explicit Dim My_rgA As Range, My_rgB As Range Dim r% '++++++++++++++++++++++++++++++++++ Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Set My_rgA = Range("A2", Range("A1").End(4)) Set My_rgB = Range("B2", Range("B1").End(4)) If Target.Cells.Count = 1 Then Select Case Target.Address Case "$E$3": get_valB Case "$F$3": get_valA End Select End If Application.EnableEvents = True End Sub '++++++++++++++++++++++++++++++++++++++ Sub get_valB() If Application.CountIf(My_rgA, Range("E3")) Then r = My_rgA.Find(Range("E3"), lookat:=1).Row If r <> 0 Then Range("F3") = My_rgB.Cells(r - 1) Else Range("F3") = vbNullString End If End Sub '+++++++++++++++++++++++++++++++++++++ Sub get_valA() If Application.CountIf(My_rgB, Range("F3")) Then r = My_rgB.Find(Range("F3"), lookat:=1).Row If r <> 0 Then Range("E3") = My_rgA.Cells(r - 1) Else Range("E3") = vbNullString End If End Sub الملف مرفق Double_formula.xlsm

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

استخدم هذه المعادلة في الخلية E2 واسحب يميناً عامود واحد و نزولاً الى اخر صف =Separate_col($C2,"\W+\d+",COLUMNS($E$1:E1)) الكود Option Explicit Function Separate_col(rg As Range, my_expression, n) Dim Obj As Object Dim matches, x, i, cnt% Dim NowArray(), Match Set Obj = CreateObject("vbscript.regexp") With Obj .Pattern = my_expression .Global = True .IgnoreCase = True End With '+++++++++++++++++++++++++ Set matches = Obj.Execute(rg.Value) x = matches.Count If x = 0 Then Separate_col = "N/A": Exit Function '============================ ReDim NowArray(x - 1) For Each Match In matches NowArray(cnt) = Match.Value cnt = cnt + 1 Next If n - 1 > UBound(NowArray) Then Separate_col = "N/A": Exit Function Separate_col = NowArray(n - 1) Set Obj = Nothing End Function الملف مرفق UDF_FORMULA.xlsm

جرب هذا الماكرو Option Explicit Sub Get_dif() Dim M As Worksheet, NT As Worksheet, NZ As Worksheet Dim LM As Single, LN As Single, i As Single Dim Dic_M As Object, Dic_N As Object Set M = Sheets("المالية") Set NZ = Sheets("النظام") Set NT = Sheets("النتائج") Set Dic_M = CreateObject("Scripting.Dictionary") Set Dic_N = CreateObject("Scripting.Dictionary") NT.Range("a1").CurrentRegion.ClearContents LM = M.Cells(Rows.Count, 1).End(3).Row LN = NZ.Cells(Rows.Count, 1).End(3).Row For i = 1 To LM If M.Range("A" & i) <> "" Then Dic_M(M.Range("A" & i).Value) = "" End If Next For i = 1 To LN If IsError(Application.Match(NZ.Range("A" & i), Dic_M.keys, 0)) Then Dic_N(NZ.Range("A" & i).Value) = "" End If Next NT.Range("A1").Resize(Dic_N.Count) = _ Application.Transpose(Dic_N.keys) Set Dic_M = Nothing: Set Dic_N = Nothing End Sub الملف مرفق Jard_Mali.xlsm

بصراحة الملف عندك مخربط بعض الشيء(اي هناك مسافات زائدة ومسافات ناقصة في الاسما بحيث لا يمكن المقارنة) اكسل يعتبر ان اسمين (حتى ولو كانا نفس الشيء) مختلفين اذا كان هناك مسافات ناقصة او زائدة بينهما مثلاً ربيع أبو العز في نظر اكسل غير ربيع أبو العز لان هناك مسافة زائدة بين ربيع و أبو بعد ترتيب الاسماء كما يجب يمكنك استعمال المعادلات في الملف المرفق (مختصر جداً حوالي 20 اسم) وسحب المعالات الى اخر صف به بيانات DEfference.xls

انطر الى التنسيق في ملفك

تنسيق الخلية حيث توجد المعادلة لا يجب ان يكون Text

يجب تحديث البيانات بالضغط على الزر اضغط هنا

جرب هذا الكود Option Explicit Private Sub CommandButton1_Click() Application.ScreenUpdating = False If ActiveSheet.Name <> "Sheet1" Then GoTo End_ME Dim targ_rg As Range If Range("B11") = vbNullString Then Set targ_rg = Range("B11") Else Set targ_rg = _ Range("B11", Range("B10")).End(4).Offset(1) End If With targ_rg.Resize(, 3) .Value = _ Application.Transpose(Range("E3").Resize(3)) .Cells(1).Offset(, -1) = .Row - 10 End With Range("B10:D" & Rows.Count).Sort key1:=Range("B10"), Header:=1 End_ME: Application.ScreenUpdating = True End Sub الملف مرفق enter_data.xlsm

جرب هذا الكود Option Explicit Sub TAJMI3() Dim MY_SH As Worksheet, SH As Worksheet Dim r%, m%, col% m = 5 Set MY_SH = Sheets("تجميع") MY_SH.Range("B5").Resize(5000, 50).ClearContents For Each SH In Sheets If SH.Name <> MY_SH.Name Then r = SH.Cells(Rows.Count, 2).End(3).Row col = SH.Cells(5, Columns.Count).End(1).Column MY_SH.Cells(m, 2).Resize(r - 4, col).Value = _ SH.Cells(5, 2).Resize(r - 4, col).Value m = m + r - 4 End If Next الملف مرفق All_sh.xlsm

تم معالجة الامر بعد تنسيق الجداول في الصفحة الاولى لحسن عمل الماكرو تغيير اسماء الشيتات الى اللغة الاجنبية لنسخ الكود ولصقه بدون ظهور احرف و كلمات غريبة الكود Option Explicit Sub All_in_One() Dim A As Worksheet, B As Worksheet Dim i%, x%, m%, ro%: m = 1 Set A = Sheets("SheetA"): Set B = Sheets("SheetB") B.Range("ِA1").CurrentRegion.ClearContents With A x = .Cells(3, Columns.Count).End(1).Column For i = 1 To x Step 5 ro = .Cells(3, i).CurrentRegion.Rows.Count B.Cells(m, 1).Resize(ro, 4).Value = _ .Cells(4, i).Resize(ro, 4).Value m = m + ro - 1 Next End With End Sub الملف مرفق MY_sheet.xlsm

لا أفهم ما السبب لهذه الكمية الكبيرة من الخلايا المدمجة في الملف التي لا لزوم لها و تعيق عمل اي معادلة او كود ما هي الغاية من ادماج الخلايا طالما يمكن توسيع العامود ايى اي قدر تريد الملف يجب تنسيقة كما في هذا الملف كي تحصل على نتائج takyim.xlsx

في هذه الحالة احذف النتسيق الشرطي من النطاق الاول

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

تفضل الملف مع المعادلات 22_salim.xlsx

جرب هذه المعادلة في الخلية V7 مع (Ctrl+Shift+Enter) ) واسحب يمينا و نزولاً =IF(ISNA(MATCH($U7&V$6,D$5:D$100&$C$5:$C$100,0)),"",INDEX($B$5:$B$100,MATCH($U7&V$6,D$5:D$24&$C$5:$C$100,0)))

اولاً اين افضل اجابة؟؟؟؟ ثانياُ استبدل في المعادلات الرقم 12 بالرقم 100 ولا تنس (Ctrl+Shift+Enter) وليس ( Enter ) وحدها لتنفيذ المعادلة واسحب نزولاً حتى اخر صف رقم 105

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

جرب احد هذين الملفين لاني لم افهم ماذا ترد بالضبط رجاء الرد ايهما تريد page_1.xlsx page_2.xlsx

ما هو انت الذي طلبت ذلك من خلال هذه العبارة في سؤالك: يتم فك الادماج واعادة كتابة البيانات في الخلية الثانية بحيث لا تترك فارغة

بعد اذن الاخ علي جرب هذا الماكرو Sub UnMergeRange() Dim i%, k%, ro%, col% Dim MY_RG As Range, CEL As Range ro = Cells(Rows.Count, 1).End(3).Row col = Cells(2, Columns.Count).End(1).Column Set MY_RG = Range("A3").Resize(ro - 2, col) MY_RG.UnMerge For Each CEL In MY_RG If CEL = vbNullString Then _ CEL = CEL.Offset(, -1) Next MY_RG.Columns.AutoFit Set MY_RG = Nothing: Set CEL = Nothing End Sub

Try this file sahb.xlsx

شاهد هذا الفيديو https://www.youtube.com/watch?v=UCiqBgdGFSs

تفضل مع التنتسيق الشرطي sal_test 2.xlsx