سليم حاصبيا

جواباً على سؤالك اردت الاسماء بخلية واحدة وليس كل اسم في خلية لا يمكن ان تحتوي خلية واحدة على اكثر من نتيجة لمعادلة واحدة (هذا امر بديهي بالنسبة للمعادلات) يمكن عمل ذلك من خلال الماكرو فقط

لقد كتبت لك بعض المعادلات في هذا الملف فقط عليك ان تكملها بالشروط التي ترديها (لم استطع فعل ذلك لضيق الوفت) jaber_new.xlsx

لا يمكن وضع معادلة على صورة كما تعرف لذلك ارفع الملف نفسه وليس صورة عنه

اذا كنت تريد القيمة الحقيقية المعادلة في الخلية F15 من هذا الملف My_test_5.xlsx

المعادلة التالية مع (Ctrl+Shift+Enter) =IF(ISNA(MATCH($E$4,$A$1:$A$85,0)),AVERAGE(INDEX($B$1:$B$85,MATCH($E$4,$A$1:$A$85)):INDEX($B$1:$B$85,MATCH($E$4,$A$1:$A$85)+1)),INDEX($B$1:$B$85,MATCH($E$4,$A$1:$A$85,0))) الملف مرفق My_test_4.xlsx

كما تعرف لا يمكن وضع معادلات على صورة لذا ارفق المف نفسه وليس صورة عنه

قم باستبدال 2 و 3 في هذين السطرين من الكود (اكتب 2 ماكن الــ 3 و 3 مكان الــ 2) sec.Cells(m, k) = S.Cells(i, 3) sec.Cells(m, k + 1) = S.Cells(i, 2)

ممكن ذلك بهذا التعديل على الماكرو Option Explicit Sub Copy_As_you_Like1() Dim S As Worksheet, sec As Worksheet Dim i% Dim Last%, m%, k%, Howmay_row Set S = Sheets("Source"): Set sec = Sheets("second_sh") sec.Range("A3").CurrentRegion.Clear m = S.Range("F6"): Howmay_row = S.Range("F7") Last = S.Cells(Rows.Count, 2).End(3).Row m = 3: k = 2 For i = 3 To Last sec.Cells(m, k) = S.Cells(i, 3) sec.Cells(m, k + 1) = S.Cells(i, 2) m = m + 1 If m Mod (Howmay_row + 3) = 0 Then m = 3: k = k + 2 End If Next With sec.Range("B3").CurrentRegion .Interior.ColorIndex = 6 .Borders.LineStyle = 1 .InsertIndent 1 End With End Sub

جرب هذا الملف هناك خياران الصفحة Targ والصفحة second_sh لا ادري ايهما تريد Copy_Many_times.xlsm

بشكل اكثر اختصاراً Sub My_code() Dim i% i = 2 Do Until Range("B" & i) = vbNullString With Range("B" & i) .Interior.ColorIndex = _ IIf(.Value > .Offset(, 1), 3, xlNone) End With i = i + 1 Loop End Sub

لنفرض ان البيانات تبدأ من الخلية A1 بدون فراغات (حتى ولو كان عندك فراغات يتوقف عند أول فراغ) جرب هذا الماكرو ( سطر وحيد) Sub test() Range("A2", Range("A1")).End(4).Offset(1).Select End Sub

جرب هذا الكود البسيط Sub My_code() Dim i% Range("B2", Range("C1").End(4)) _ .Interior.ColorIndex = xlNone i = 2 Do Until Range("B" & i) = vbNullString If Range("B" & i) > Range("C" & i) Then _ Range("B" & i).Interior.ColorIndex = 3 i = i + 1 Loop End Sub

هذا الكود يحل المشكلة Option Explicit Sub My_sum() Dim r%, S# r = 1 With Sheets("ورقة1") Do Until r > .Cells(Rows.Count, 1).End(3).Row If .Range("A" & r).Interior.ColorIndex <> xlNone And _ .Range("A" & r) = "جامعة" Then S = S + 1 End If r = r + 1 Loop: .Cells(2, 6) = S End With End Sub

جرب هذا الملف تم ازالة الالوان الفاقعة لسهولة تتبع المعادلات (يمكنك اعادة النتسيق كما كان اذا اردت ذلك) لا تحصل عل نتيجة اذا لم يكن مذكورا وقت الدخول ووقت الخروج لاي موظف النطاق الازرق(حيث المعادلات) يمكنك سحبه الى الى مجال تريد، وتحديد بداية الدوام ونهايته من الخليتين K1 & K2 Attendance_Feb.xlsx

من الصعب جداً (وليس من المستحيل) وضع معادلات تأخذ مراجعها من خلايا مدمجة (العامود A ) انت تدمج كل 5 صفوف في خلية واحدة

للمرة الالف اكرر(مع ان المعادلات لحساب التكرارات) يمنع وضع خلايا مدمجة حيث توجد معادلات تم ازالة دمج الخلايا من خلايلا المعادلات هذه المعادلة في الخلية D21 واسحب نزولاً =SUMPRODUCT(--($B$5:$B$18=$B22),--($D$5:$D$18=CHOOSE(COLUMNS($A$1:A1),"داخلي","خارجي"))) الملف مرفق tekrar.xlsx

جرب هذا (النموذج) عن الملف من الارشيف Working time.xlsx

ربما يكون المطلوب تم تغيير معادلة الترقيم معادلة واحدة لكل الصفوف(وليس ابتداء من الصف الثاني ) MY_example1.xlsx

جرب هذا الماكرو Sub Transfer_with_total() Dim Cell As Range, t As String, LR As Long, LRT As Long Dim WS As Worksheet, Answer As Long, Bol As Boolean Dim Ro As Long Set WS = Sheets("Main") LR = WS.Cells(1000, 3).End(xlUp).Row t = WS.Range("c1").Value Application.ScreenUpdating = False If Not IsEmpty(WS.Range("c1")) Then Bol = Evaluate("=ISREF(" & "'" & WS.Range("c1") & "'!A1)") If Not Bol Then Sheets.Add(, after:=Sheets(Sheets.Count)).Name = WS.Range("c1") WS.Range("A2:g" & LR).Copy With ActiveSheet .Range("a1").PasteSpecial (xlPasteValuesAndNumberFormats) .Range("a1").PasteSpecial (xlPasteColumnWidths) .Range("a1").PasteSpecial (xlPasteFormats) .DisplayRightToLeft = False End With WS.Select GoTo End_me End If WS.Range("A3:g" & LR).Copy With Sheets(t) LRT = .Cells(Rows.Count, 2).End(xlUp).Row + 1 With .Cells(LRT, 1) .PasteSpecial (xlPasteValuesAndNumberFormats) .PasteSpecial (xlPasteColumnWidths) .PasteSpecial (xlPasteFormats) End With Ro = Application.CountA(.Range("c" & LRT).Resize(LR - 2)) .Cells(Ro + LRT, 2) = "Total" .Cells(Ro + LRT, 2).Resize(, 3).HorizontalAlignment = 7 .Cells(Ro + LRT, 5) = WS.Range("h3") End With Answer = MsgBox("Do you want to Clear the data on Sheet1 or not?", vbYesNo + vbQuestion) If Answer = vbYes Then Sheets("Main").Activate Sheets("Main").Range("b3:d1000,f3:f1000").Select Selection.ClearContents Else: End If Else End If End_me: Application.CutCopyMode = False Application.ScreenUpdating = True End Sub الملف مرفق Supplier_new.xlsm

بعد اذن الاخ علي هذا الكود Option Explicit Sub Extract_by_Groupes() Rem Created By Salim Hasbaya On 19/2/2020 If ActiveSheet.Name <> "ورقة1" Then Exit Sub Application.Calculation = xlCalculationManual Dim ObjReg As Object Dim ObjMatches, a%, My_word, i% Dim k%, col%, last_row last_row = Cells(Rows.Count, 1).End(3).Row Range("E6:G" & last_row).Clear Set ObjReg = CreateObject("VBScript.RegExp") With ObjReg .Pattern = "(\W+)(\d+)[%-:,_](\W+)" .Global = True End With For k = 6 To last_row If ObjReg.test(Range("a" & k)) Then Set ObjMatches = ObjReg.Execute(Range("a" & k)) For Each My_word In ObjMatches 'The variable match will contain the full match a = My_word.Submatches.Count 'total number of groups in the full match col = 5 For i = 0 To a - 1 Cells(k, col) = My_word.Submatches(i) col = col + 1 Next Next End If col = 5 Next With Range("E6:G" & last_row) .Borders.LineStyle = 1 .Font.Size = 14 .Font.Bold = True .InsertIndent 1 .Columns.AutoFit .Interior.ColorIndex = 40 End With Set ObjReg = Nothing Application.Calculation = xlCalculationAutomatic End Sub الملف مرفق Extract Number.xlsm

أولاً اذا كنت انا وانت نعرف الذكر من الانثى من خلال اسم الشخص فكيف للاكسل ان يفعل ذلك ان لم تدرج عامود اضافي فيه ذكر او انثى ثانيا لا تقل الفصل الاول او الثاني تكلم بلغة الاكسل وقل في اي عامود يجب التفتيش عن كلمة مقبول و جيد

جرب هذا الكود Option Explicit Sub Extract_by_Groupes() Rem Created By Salim Hasbaya On 19/2/2020 If ActiveSheet.Name <> "Salim" Then Exit Sub Dim ObjReg As Object Dim ObjMatches, a%, My_word, i% Dim k%, col%, last_row last_row = Cells(Rows.Count, 1).End(3).Row Range("C1:E" & last_row).Clear Set ObjReg = CreateObject("VBScript.RegExp") With ObjReg .Pattern = "(\w+)\s*?(\d+)\s*?([(]\s*?.\s*.+)" .Global = True End With For k = 1 To last_row If ObjReg.test(Range("a" & k)) Then Set ObjMatches = ObjReg.Execute(Range("a" & k)) For Each My_word In ObjMatches 'The variable match will contain the full match a = My_word.Submatches.Count 'total number of groups in the full match col = 3 For i = 0 To a - 1 Cells(k, col) = My_word.Submatches(i) col = col + 1 Next Next End If col = 3 Next With Range("C1:E" & last_row) .Borders.LineStyle = 1 .Font.Size = 14 .Font.Bold = True .InsertIndent 1 .Columns.AutoFit .Interior.ColorIndex = 15 End With Set ObjReg = Nothing End Sub الملف مرفق Ungroup_Text.xlsm

كود رائع لكن من الافضل تقصير الحلقات التكرارية (لا داعي لتشغيلها حتى الصف رقم 1000 منها 995 صف فارغ) ما ادرانا عدد الصفوف ربما اكثر من 1000 أو اقل لماذا لا نجعل اكسل وحده يحدد عدد الصفوف (10 15 .... 100 ... 1000 الخ.) اقترح هذا الكود Sub rangeToColumn() Dim i%, m% i = 2: m = 2 Range("c2").Resize((Range("a2").CurrentRegion.Rows.Count) * 3) _ .ClearContents Do Until Range("a" & i) = vbNullString With Cells(m, 3) .Value = Range("A" & i) .Offset(1) = Range("B" & i) End With m = m + 2 i = i + 1 Loop End Sub

ارفع الملف نفسه لا يمكن التعامل مع صورة على كل حال اليك هذا النموذج الذي تستطيع العمل عليه Join_Columns.xlsx

اذا كان ما فهمته صحيح المطلوب في هذا الملف Oujour.xlsx