سليم حاصبيا

Try This Macro Option Explicit Sub Colorize_Comments() Const CLR = 35 With Range("A1").CurrentRegion .Interior.ColorIndex = xlNone .SpecialCells(1).Interior.ColorIndex = CLR End With End Sub

Try This New File Salim_book.xlsm

من اين جئت بهذه الارقام

ارفق ملف بسيط فيه النتائج التي تتوقعها

تمت معالجة الأمر Issa.xlsx

بعد اذن الاخ أبو البشر هذا الكود ( لا يسمح بتكرار الأسماء) Option Explicit Sub test() Dim i% Dim Obj As Object Set Obj = CreateObject("Scripting.Dictionary") Sheets("re").Cells(12, 1).Resize(15, 3).ClearContents i = 3 With Sheets("الجمعة") Do While .Cells(i, 3).Value <> "" If .Cells(i, 2) <> vbNullString Then Obj(.Cells(i, 3).Value) = vbNullString End If i = i + 1 Loop End With If Obj.Count Then With Sheets("re").Cells(12, 2).Resize(Obj.Count) .Value = Application.Transpose(Obj.keys) .Offset(, -1) = Evaluate("Row(1:" & Obj.Count & ")") End With End If Set Obj = Nothing End Sub

جرب هذا الملف يحتوي على 3 أكواد ( الكود الأول لتعريف المتغيرات الكود الثاني يقوم باضافة اسماء المرضى الثّالث للفواتير) الأكواد الثلاثة تعمل معاَ بالضغط على الزر "Give Data" Option Explicit Global D As Worksheet Global LrR%, m%, i% Global R As Worksheet '+++++++++++++++++++++++++ Sub Debut() ' Code #1 Set D = Sheets("Dr_Repport") Set R = Sheets("Repport") LrR = R.Cells(Rows.Count, 2).End(3).Row End Sub '++++++++++++++++++++ Sub Uniqe_Malade() Debut ' Code #2 If LrR < 5 Then Exit Sub D.Range("A8:b8").Resize(1000).ClearContents m = 8 For i = 5 To LrR If Application.CountIf(R.Range("B5:B" & i), R.Range("B" & i)) = 1 Then D.Cells(m, 2) = R.Range("B" & i) D.Cells(m, 1) = m - 7 m = m + 1 End If Next End Sub '+++++++++++++++++++ Sub Doctors_Facture() ' Code #3 Rem Created by Salim Hasbaya On 23/10/2020 Uniqe_Malade Dim k%, RoR%, RoD%, x%, t% Dim all#, y% Dim arr(1 To 4) RoR = R.Cells(Rows.Count, 2).End(3).Row If RoR < 5 Then Exit Sub RoD = D.Cells(Rows.Count, 2).End(3).Row If RoD < 8 Then Exit Sub arr(1) = "دكتور حاتم": arr(2) = "دكتور احمد" arr(3) = "دكتورة رانيا": arr(4) = "دكتور محمد" D.Range("C8:N1000").ClearContents For k = 1 To 4 y = 8 For t = 8 To RoD For x = 5 To RoR If R.Cells(x, "i") = arr(k) _ And R.Cells(x, "B") = D.Cells(t, 2) Then all = all + IIf(IsNumeric(R.Cells(x, "H")), _ R.Cells(x, "H"), 0) End If Next x With D.Cells(y, 3 * k) .Value = all .Offset(, 1) = Round(all * 0.4, 2) .Offset(, 2) = Round(all * 0.6, 2) End With all = 0: y = y + 1 Next t Next k End Sub الملف مرفق Adb_naser.xlsm

تم معالجة الامر لأظهار الفورم اضغط على الزر "CLICK" (يمكنك العمل على الشيت حنى ولو كان اليوزر ظاهراً) 1- تقوم بكنابة الرمز الذي تريد في النكست بوكس الاصفر 2 -تقوم باستدعاء ببانات هذا الرمز الى التكست بوكسات الباقية من خلال الضغط على الزر " استدعاء" 3- تفوم بتعديل ما تريد في التكسن بوكسات 4- تضغط على الزر تعديل 5- بهذا تنتقل البيانات الى المكان المناسب في الشيت الملف مرفق Shible.xlsb

يمكن انك تريد هذا الشيء Option Explicit Sub Yemken_Matloub() Dim S1 As Worksheet Dim S2 As Worksheet Dim Db As Object, Dc As Object Dim lr%, i%, m%, Cont% Dim ar Set S1 = Sheets("Sheet1") Set S2 = Sheets("Sheet2") Set Db = CreateObject("Scripting.Dictionary") Set Dc = CreateObject("Scripting.Dictionary") lr = S2.Cells(Rows.Count, 1).End(3).Row If lr = 1 Then Exit Sub Cont = S1.Range("A1").CurrentRegion.Rows.Count If Cont > 1 Then S1.Range("A1").CurrentRegion. _ Offset(1).Resize(Cont - 1).Clear End If i = 2 Do Until i = lr + 1 Db(S2.Cells(i, 1).Value) = Db(S2.Cells(i, 1).Value) + _ IIf(IsNumeric(S2.Cells(i, 2).Value), S2.Cells(i, 2).Value, 0) If Not Dc.Exists(S2.Cells(i, 1).Value) Then Dc(S2.Cells(i, 1).Value) = S2.Cells(i, 3).Value Else Dc(S2.Cells(i, 1).Value) = Dc(S2.Cells(i, 1).Value) & "*" _ & S2.Cells(i, 3).Value End If i = i + 1 Loop m = 2 For i = 0 To Db.Count - 1 S1.Cells(m, 1) = Db.keys()(i) S1.Cells(m, 2) = Db.items()(i) ar = Split(Dc.items()(i), "*") S1.Cells(m, 3).Resize(, UBound(ar) + 1) = ar m = m + 1 Next Cont = S1.Range("a1").CurrentRegion.Rows.Count If Cont = 1 Then GoTo Bay_Bay With S1.Range("A1").CurrentRegion. _ Offset(1).Resize(Cont - 1).SpecialCells(2, 23) .Borders.LineStyle = 1 .InsertIndent 1 .Font.Bold = True .Font.Size = 16 .Interior.ColorIndex = 35 End With Bay_Bay: Set S1 = Nothing: Set S2 = Nothing Set Db = Nothing: Set Dc = Nothing End Sub الملف مرفق Hisham_Invpice.xlsm

حاول ان تستعمل الحلفات التكرارية لاختصار الكود (بين علامات الــــ ++++) (لأن 5 تكست بوكسات عدد مقبول ربما يكون هناك 50 تكس بوكس فهل يجب ان نذكرها واحداً واحداً في الكود ؟؟؟) (/ كل واحد مرتين مرة لنسخه الى الخلية ومرة ثانية لمسح محتواه / ) مثلاً زر الاضافة Option Explicit Private Sub CommandButton1_Click() Dim Ws As Worksheet Dim lr, i% Application.EnableEvents = False Set Ws = Sheets("الملاك") lr = Ws.Cells(Rows.Count, 2).End(3).Row If TextBox1 = "" Then _ MsgBox "عفوا يجب ادخال الرمز", _ vbExclamation: GoTo End_Me If Application.WorksheetFunction. _ CountIf(Ws.Range("b2:b" & lr), TextBox1) > 0 Then _ MsgBox "عفوا هذا الرمز موجود", _ vbInformation: GoTo End_Me Ws.Range("A" & lr + 1) = lr '+++++++++++++++++++++++++++++++++++++++++++++ For i = 0 To 4 With Ws.Range("b" & lr + 1) .Offset(, i) = Me.Controls("TextBox" & i + 1) Me.Controls("TextBox" & i + 1) = vbNullString End With Next '+++++++++++++++++++++++++++++++++++++++++++++++++ MsgBox "تمت الاضافة بنجاح" End_Me: TextBox1.SetFocus Application.EnableEvents = True End Sub بالنسبة للزر "اظهار اخر رمز" Private Sub CommandButton3_Click() Dim Ws As Worksheet Dim lr%, I% Set Ws = Sheets("الملاك") lr = Ws.Cells(Rows.Count, 2).End(3).Row For I = 1 To 5 Me.Controls("TextBox" & I).Value = _ Ws.Range("b" & lr).Offset(, I - 1) Next End Sub

بعد اذن الاخ علي لا يتم الترتيب الا اذا 1-كان هناك بيانات في الأعمدة B / C / D ( الترقيم لا ضرورة له لانه يتم اوتوماتيكياً) 2- تمت الكتابة في اول صف غير فارغ Option Explicit Dim RG As Range, Ro '++++++++++++++++++++++++++++++++++ Private Sub Worksheet_Change(ByVal Salim As Range) Set RG = Range("A2").CurrentRegion Ro = RG.Rows.Count With Application .EnableEvents = False .Calculation = xlCalculationManual .ScreenUpdating = False End With If Ro = 1 Then GoTo Bay_Bay If Salim.Row = Ro + 1 And _ Application.CountA(Cells(Salim.Row, 2) _ .Resize(, 3)) = 3 Then RG.Sort Range("D2"), 2, Header:=1 With RG.Offset(1).Resize(Ro - 1) .Columns(1) = Evaluate("row(1:" & Ro - 1 & ")") .HorizontalAlignment = 1 .InsertIndent 1 .Font.Size = 18 .Font.Bold = True .Borders.LineStyle = 1 End With End If Bay_Bay: With Application .EnableEvents = True .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With End Sub الملف مرفق Auto_sort.xlsm

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

غادر الصفحة ثم ارجع اليها

تم معالجة الامر بواسطة الكود ( الكود اوتوماتيكي يعمل بمجرد ما تختار اي رقم ) ولا حاجة لاستدعاءه بواسطة زر صفحة Salim من هذا الملف الكود Sub By_Macro() Dim s As Worksheet Dim D As Worksheet Dim F_rg As Range Dim ro% Set s = Sheets("Salim"): Set D = Sheets("Data") s.Cells(6, 4).Resize(, 5).ClearContents If s.Cells(6, 3) = vbNullString Then Exit Sub Set F_rg = D.Range("A1").CurrentRegion.Columns(1). _ Find(s.Cells(6, 3), LookIn:=xlValues, lookat:=1) If F_rg Is Nothing Then Exit Sub ro = F_rg.Row s.Cells(6, 4).Resize(, 5).Value = _ D.Cells(ro, 2).Resize(, 5).Value End Sub report_Ali_New.xlsm

جرب هذا الملف report_Ali.xlsm

الظاهر ان المشكلة عندك في الــ Windows جرب ان تنفذ الماكرو من جهاز اخر او دع احد غيرك يحمل الملف ويجربه

قم بهذه التعديلات على الكود كما في الصورة (الغامود ِِA في صحفة التصنيفات فارغ تماما) البيانات في الصفحة " البيان " يجب ان تكون في العامود B ابتداء من الصف رقم 2

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

تم التعديل على الملف قليلا من حيث المظهر والتنسيق Option Explicit Sub MY_code() Rem Created by Salim Hasbaya On 19/10/2020 Application.ScreenUpdating = False Dim B As Worksheet, Tas As Worksheet Dim arr() Dim i%, t%, col%, p%, n%, Q%, LB% Dim St$, itm As Variant Dim Rg As Range Set B = Sheets("البيان") Set Tas = Sheets("التصنيفات") Set Rg = Tas.Range("B1").CurrentRegion If Rg.Rows.Count = 1 Then GoTo Ma_Lish_Da3wa Set Rg = Rg.Offset(1).Resize(Rg.Rows.Count - 1) LB = B.Cells(Rows.Count, 2).End(3).Row B.Range("D2").CurrentRegion.ClearContents If LB = 1 Then GoTo Ma_Lish_Da3wa For i = 1 To Rg.Cells.Count If Rg.Cells(i) <> "" Then ReDim Preserve arr(t) arr(t) = Rg.Cells(i) t = t + 1 End If Next t = 2 B.Range("D2").Resize(LB - 1) = _ B.Range("B2").Resize(LB - 1).Value '+++++++++++++Creating The Data +++++++++++++ For i = 2 To LB If B.Range("D" & i) <> vbNullString Then For Each itm In arr If InStr(B.Range("D" & i), itm) Then col = Rg.Find(itm, lookat:=1).Column St = Replace(B.Range("D" & i), itm, "*") col = Rg.Find(itm, lookat:=1).Column St = Replace(St, "*", Tas.Cells(1, col)) B.Range("D" & i) = St End If Next itm End If Next i '+++++++++++++ End Of Creating The Data +++++++++++++ Erase arr ReDim arr(1 To 3) For i = 1 To 3 arr(i) = Tas.Cells(1, i + 1) Next p = 1 '+++++++++++++Formating with Red Color +++++++++++++ For i = 2 To LB For Each itm In arr Do Q = InStr(p, B.Range("D" & i), itm) If Q = 0 Then Exit Do n = InStr(Q, B.Range("D" & i), " ") p = p + n + 1 B.Range("D" & i).Characters(Q, n - Q). _ Font.ColorIndex = 3 Loop p = 1 Next itm Next i '++++++++++++++End Of Formating with Red Color +++++++++++++ Ma_Lish_Da3wa: Set B = Nothing: Set Tas = Nothing Set Rg = Nothing: Erase arr Application.ScreenUpdating = True End Sub الملف من جديد مع الكودين القديم والجديد Mh_Fayz _New.xlsm

لا أعلم ما المشكلة عندك ربما يكون اصدار الاوفيس قديماً عتدي يعمل الماكرو بشكل طبيعي جرب تبدل هذا السطر %Dim i الى #Dim i

ليس من الضروري رفع الملف بكامله (أكثر من 1000 صف) كان يكفي نبذة صغيرة عنه (حوالي 20 صف) لأن الماكرو الذي يعمل على صف واحد يمكنه العمل على الالوف تم معالجة الأمر (مع التتغيير الى البيانات الضغيرة نسبياُ لمشاهذة عمل لماكرو بشكل جيد لأنه ليس من الضروري ان اقرأ اسم كل كتاب و مؤلفه و ما الى ذلك يكفي ان الاجظ الاحرف A / B/ C ان كانت في مكانها الصحيح) يمكنك نسخ الكود الى الملف عندك وتنقيذه مع مراعاة تغيير اسم الصفخة في الماكرو من Salim الى الاسم الذي عندك Sub Salim_Test() Dim Ro As Long, Rg As Range Dim x As Long, t As Long, i As Long, k% With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With With Sheets("Salim") Ro = .Cells(Rows.Count, 1).End(3).Row Set Rg = .Range("A2:A" & Ro).SpecialCells(2, 23) .Range("H2").Resize(Ro, 6).Clear t = 2 For x = 1 To Rg.Areas.Count .Cells(t, "H").Resize(Rg.Areas(x).Rows.Count) = _ Rg.Areas(x).Cells(1, 1) .Cells(t, "H").Interior.ColorIndex = 6 .Cells(t + 1, "I"). _ Resize(Rg.Areas(x).Rows.Count - 1, 5).Value = _ Rg.Areas(x).Cells(2).Offset(, 1). _ Resize(Rg.Areas(x).Rows.Count - 1, 5).Value t = t + Rg.Areas(x).Rows.Count + 1 Next x With .Range("H2").Resize(Ro, 6).SpecialCells(2, 23) .Borders.LineStyle = 1 .Font.Bold = True .InsertIndent 1 .Columns.AutoFit End With End With With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub Sk_Khalige_Six.xlsm

بعد ادن اخي محي الدين و زيادة في اثراء الموضوع هذا الكود Option Explicit Sub test_1() Dim arr(), i%, t%, itm, col% Dim B As Worksheet Dim Tas As Worksheet Set B = Sheets("البيان") Set Tas = Sheets("التصنيفات") B.Range("D2").CurrentRegion.ClearContents Dim Rg As Range Set Rg = Tas.Range("B2:D20") For i = 1 To Rg.Cells.Count If Rg.Cells(i) <> "" Then ReDim Preserve arr(t) arr(t) = Rg.Cells(i) t = t + 1 End If Next t = 2 For i = 2 To 9 For Each itm In arr If InStr(B.Cells(i, 2), itm) Then col = Rg.Find(itm, lookat:=1).Column B.Cells(t, 4) = Replace(B.Cells(i, 2), _ itm, Tas.Cells(1, col)) t = t + 1: Exit For End If Next itm Next i End Sub الملف مرفق Mh_Fayz.xlsm

هذا عمل من الصعب تنفيذه بالمعادلات جرب هذا الكود Option Explicit Sub Extract_Codes() Dim col As Object Dim i% Dim RoB%, RoD% Set col = CreateObject("System.Collections.ArrayList") With Sheets("Sheet2") i = 2 Do Until .Cells(i, 1) = vbNullString If Not col.Contains(.Cells(i, 2).Value) _ And .Cells(i, 2) <> "" _ And IsNumeric(.Cells(i, 2)) Then col.Add .Cells(i, 2).Value End If If Not col.Contains(.Cells(i, 4).Value) _ And .Cells(i, 4) <> "" _ And IsNumeric(.Cells(i, 4)) Then col.Add .Cells(i, 4).Value End If i = i + 1 Loop col.Sort .Cells(1, "I").CurrentRegion.ClearContents .Cells(1, "I").Resize(col.Count).Value = _ Application.Transpose(col.ToArray) End With End Sub الملف مرفق Saher.xlsm

قلت دون كلمات لا معنى لها هل هناك شركة باسم غشاخخ أو لخخخلث

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