سليم حاصبيا

بحب اضافة ما يلي على الأكواد الملف من جديد Jadid_YARA_2User Uniqus..xlsm

هذه لم افهما وخانة اخرى تقوم بترحيل الرقم الذى يكتب فيها الى العمود j بدا من j2 الباقي في الملف NewYARA_2User Uniqus..xlsm

المطلوب غير مفهوم اين تريد ادراج المعلومات؟؟؟؟ حاولت ان ادرجها لك في ListBox كما في المثال المرفق (اختر اسم الشيت من الــ ConboBox) aboezz623.xlsm

أخي أحمد شكراً على هذه النداءات التي تقوم لها من أجلي و من أجل باقي الأعضاء الذين يقومون بالمساعدة دون اي بدل مادي و أعدك اي صاحب سؤال لا يستجيب لهذه النداءات سوف يضاف عندي الى "القائمة السوداء" التي تحتوي حالياً على حوالي 5 أشخاص بحيث امتنع عن تقديم مساعدة له

قم اضافة ما بلي على الكود (حسب الصورة) الملف مرفق malak.xlsm

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

تم مغالجة الأمر و زيادة حبتين بجيث يمكنك الاتنقال الى اي شيت من خلال الضغط عل اسمها من الخلايا الصفراء صغحة (Salim) والعودة من اي شيت الى الرئيسية من حلال الضغط على الخلية Go to Salim ( لكن في المرة القادمة عليك بتوضيح كل شيء لعدم اهدار الوقت) Option Explicit '+++++++++++++++++++++++++++++++++++++++++ Sub ADD_SH_with_HyperLink() 'code to add Sheets One Time WITH HYPERLINKS 'Crated By Salim Hasbaya On 1/10/2020 ' Dim Rg As Range Dim sh As Worksheet Dim LB%, i%, x%, t% Dim Ws As Worksheet Set sh = Sheets("Salim") Application.ScreenUpdating = False Application.DisplayAlerts = False For Each Ws In Sheets If Ws.Name <> "Salim" Then Ws.Delete End If Next Application.DisplayAlerts = True LB = sh.Cells(Rows.Count, 2).End(3).Row For x = 2 To LB If sh.Range("b" & x) <> "" Then t = sh.Range("b" & x).MergeArea.Rows.Count If Not Application.Evaluate("ISREF('" & sh.Range("b" & x) & "'!A1)") Then Sheets.Add after:=Sheets(Sheets.Count) With ActiveSheet .Name = sh.Range("B" & x) sh.Range("A1:D1").Copy .Range("A1").PasteSpecial (11) .Range("A1").PasteSpecial (8) .Hyperlinks.Add Anchor:=.Range("F1"), _ Address:="", SubAddress:= _ "Salim!A1", TextToDisplay:="Goto SALIM" With .Range("A1").CurrentRegion .ColumnWidth = 19 .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 16 .Rows(2).InsertIndent 1 .Cells(2, 1).Select End With With .Range("F1") With .Font .Bold = True: .Size = 20 .ColorIndex = vbBlack .Italic = True End With .Interior.ColorIndex = 6 .Borders.LineStyle = 1 .Columns.AutoFit End With End With End If 'sh,exist End If '.value<>"" x = x + t - 1 Next x sh.Select add_data add_Hyper Application.CutCopyMode = False Application.ScreenUpdating = True End Sub '++++++++++++++++++++++++++++++++++ Sub add_data() Dim sh As Worksheet Dim LB%, i%, x%, t% Dim Ws As Worksheet Dim spec_sh As Worksheet Dim LS%, Ro% Set sh = Sheets("Salim") LS = sh.Cells(Rows.Count, 1).End(3).Row For i = 2 To LS t = sh.Cells(i, 2).MergeArea.Rows.Count Set spec_sh = Sheets(sh.Cells(i, 2) & "") Ro = spec_sh.Cells(Rows.Count, 1).End(3).Row + 1 sh.Cells(i, 1).Resize(t, 4).Copy _ spec_sh.Range("A" & Ro) i = i + t - 1 Next i End Sub '+++++++++++++++++++++++ Sub add_Hyper() Dim Ws As Worksheet Dim K% Set Ws = Sheets("Salim") Ws.Range("F2:F" & Sheets.Count).Clear For K = 2 To Sheets.Count Ws.Range("F" & K) = Sheets(K).Name Ws.Range("F" & K).Hyperlinks.Add _ Anchor:=Ws.Range("F" & K), _ Address:="", _ SubAddress:="'" & Sheets(K).Name & "'!A1", _ TextToDisplay:="Go TO " & Sheets(K).Name Next With Ws.Range("F2").Resize(K - 2) .Interior.ColorIndex = 6 .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14: .Font.Bold = True End With End Sub الملف مرفق Adb_Explicit.xlsm

كان من المفروض ان تقول هذا الشيء من البداية بدون اضاعة الوقت لانشاء الكود أعتذر عن المتابعة (لا وقت لذلك)

قم بتسمية الشيت الاول باسم Salim ثم نفذ هذا الماكرو Option Explicit '+++++++++++++++++++++++++++++++++++++++++ Sub ADD_SH_with_HyperLink() 'code to add Sheets One Time WITH HYPERLINKS 'Crated By Salim Hasbaya On 1/10/2020 Dim Rg As Range Dim sh As Worksheet Dim LB%, i%, x%, t% Dim ws As Worksheet Set sh = Sheets("Salim") Application.ScreenUpdating = False Application.DisplayAlerts = False For Each ws In Sheets If ws.Name <> "Salim" Then ws.Delete End If Next Application.DisplayAlerts = True LB = sh.Cells(Rows.Count, 2).End(3).Row For x = 2 To LB If sh.Range("b" & x) <> "" Then t = sh.Range("b" & x).MergeArea.Rows.Count If Not Application.Evaluate("ISREF('" & sh.Range("b" & x) & "'!A1)") Then Sheets.Add after:=Sheets(Sheets.Count) With ActiveSheet .Name = sh.Range("b" & x) sh.Range("a1:d1").Copy .Range("A1").PasteSpecial (xlPasteAll) .Range("C:C").Delete .Range("A2") = sh.Range("A" & x) .Range("B2") = sh.Range("B" & x) .Range("C2") = sh.Range("D" & x) .Hyperlinks.Add Anchor:=.Range("F1"), _ Address:="", SubAddress:= _ "Salim!A1", TextToDisplay:="Goto SALIM" With .Range("a1").CurrentRegion .ColumnWidth = 19 .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 16 .Rows(2).InsertIndent 1 .Cells(2, 1).Select End With With .Range("F1") With .Font .Bold = True: .Size = 20 .ColorIndex = vbBlack .Italic = True End With .Interior.ColorIndex = 6 .Borders.LineStyle = 1 .Columns.AutoFit End With End With End If 'sh,exist End If '.value<>"" x = x + t - 1 Next x sh.Select Application.ScreenUpdating = True End Sub '++++++++++++++++++++++++++++++++++++++++++++++++++ الملف مرفق ABd_Naser_Sheet.xlsm

هناك مسافة زائدة في اسم الصفحة "يناير "يجب ازالتها قم باضافة شيت تحت اي اسم مثلاً "Summation" بدون كود هذه المعادلة =SUM('يناير:مارس'!D4) أو هذا الكود Option Explicit Sub test() Dim First As Worksheet Dim Last As Worksheet Set First = Sheets("يناير") Set Last = Sheets("مارس") With Sheets("Summation").Range("D4") .Formula = "=SUM('" & First.Name & ":" & Last.Name & "'!D4)" .Value = .Value End With End Sub النلف مرفق Hissam.xlsm

تم التعديل على الملف hassan rady_1.xlsb

مش تقول كده من الصبح ولا لزوم لورقة مساعدة مع العديد من الأعمدة المساعدة فيها hassan rady.xlsb

انت تعرف ان الماكرو الذي يعمل على صف واحد يمكنه العمل غلى الوف الصقوف لماذا اذن تحميل ملف بهذا الخجم الكبير 1.5 ميغا مما يجعل عمليةتتبع الكود صعبة جداً لذلك كي تجد مساعدة: 1- ارفع نموذج بسيط عما تريد (10 الى 15 صف لا أكثر) 2- أزالة كافة التنسيقات والزركشات ( من ألوان تبهر نظر من يقوم يقوم بالمساعدة )و تجعله غير متحمس للمساعدة بل و ينفر منها ومباشرة الى سله المهملات في الجهاز 3- شرح كافي وواضح لما تريد 4- حذف كل الصفحات التي لا علاقة لها بأمور البحث

تم معالجة الامر بطريقة اخرى (عدم كتابة الترقيم في العامود الأول لانه يدرج تلقائياً) القائمة المنسدلة مطاطة (تستيجيب لاي تعدبل أو زيادة في البيانات) Psycho.xlsx

تم التعديل Option Explicit Sub GetMe_All() Dim sh1 As Worksheet Dim sh2 As Worksheet Dim LR1 As Single, LR2 As Single Dim m As Single, t As Single, x As Single Set sh1 = Sheets("Sheet1") Set sh2 = Sheets("Sheet2") LR1 = sh1.Cells(Rows.Count, 2).End(3).Row LR2 = sh2.Cells(Rows.Count, 1).End(3).Row m = 2 If LR1 > 1 Then Union(sh1.Range("A2:A" & LR1), sh1.Range("B2:B" & LR1), _ sh1.Range("D2:D" & LR1)).ClearContents End If For x = 2 To LR2 t = sh2.Cells(x, 2).MergeArea.Rows.Count With sh1.Cells(m, 2) .Offset(, -1) = "From " & x - 1 & " To " & t + x - 2 .Value = sh2.Cells(x, 2) .Offset(, 2) = sh2.Cells(x, 4) End With x = x + t - 1 m = m + 1 Next End Sub الملف من جديد Naser_1.xlsm

Required code Option Explicit Sub Get_All() Dim sh1 As Worksheet Dim sh2 As Worksheet Dim LR1 As Single, LR2 As Single Dim m As Single, t As Single, x As Single Set sh1 = Sheets("Sheet1") Set sh2 = Sheets("Sheet2") LR1 = sh1.Cells(Rows.Count, 2).End(3).Row LR2 = sh2.Cells(Rows.Count, 1).End(3).Row m = 2 If LR1 > 1 Then Union(sh1.Range("B2:B" & LR1), _ sh1.Range("D2:D" & LR1)).ClearContents End If For x = 2 To LR2 If sh2.Cells(x, 2).MergeCells Then t = sh2.Cells(x, 2).MergeArea.Rows.Count With sh1.Cells(m, 2) .Value = sh2.Cells(x, 2) .Offset(, 2) = sh2.Cells(x, 4) End With x = x + t - 1: m = m + 1 Else With sh1.Cells(m, 2) .Value = sh2.Cells(x, 2) .Offset(, 2) = sh2.Cells(x, 4) End With m = m + 1 End If Next End Sub الملف مرفق Naser.xlsm

يا أخي كلما عدلت في البيانات و بعد الانتهاء من التعديل (ولو كانوا 100 صف أو أكثر) اضغط الزر Run

الكود الصحيح Sub Vlookup_Example() Dim Sh1 As Worksheet Dim SH2 As Worksheet Dim X1%, X2% Set Sh1 = Sheets("Example 1") Set SH2 = Sheets("Example 2") X1 = Sh1.Cells(Rows.Count, 1).End(3).Row X2 = SH2.Cells(Rows.Count, 4).End(3).Row SH2.Cells(2, "E").Resize(X2 - 1).Formula = _ "=IFERROR(VLOOKUP(D2,'Example 1'!A1:B" & X1 & ",2,0),"""")" End Sub الملف مرفق Yasser_sat.xlsm

هذا الكود يقوم بذلك Option Explicit Sub Sum_Merged_Cells_By_Formula() Rem Created By Salim Hasbaya On 29/9/2020 If ActiveSheet.Name <> "Salim" Then GoTo Bay_Bay Application.ScreenUpdating = False Dim Ro%, X% Dim t%, k%, Roc% Ro = Cells(Rows.Count, 2).End(3).Row Roc = Cells(Rows.Count, 3).End(3).Row With Range("D2:D" & Roc) .UnMerge .Clear End With For X = 2 To Ro If Cells(X, 2).MergeCells = True Then t = Cells(X, 2).MergeArea.Rows.Count Cells(X, 4).Resize(t).Merge Cells(X, 4).Formula = _ "=SUM(C" & X & ":C" & X + t - 1 & ")" X = X + t - 1 Else Cells(X, 4).Formula = "=SUM(C" & X & ")" End If Next X With Range("D2:D" & Roc) .VerticalAlignment = 2 .HorizontalAlignment = 3 .Borders.LineStyle = 1 .Font.Size = 18 .Font.Bold = True End With Bay_Bay: Application.ScreenUpdating = True End Sub Abd_naser_New.xlsm

جرب هذا الملف صفحة Salim Option Explicit Sub sum_merged_cells() If ActiveSheet.Name <> "Salim" Then Exit Sub Dim Rg As Range Dim Ro%, X%, m% Dim t%, y%, s#, k%, Roc% Ro = Cells(Rows.Count, 2).End(3).Row Roc = Cells(Rows.Count, 3).End(3).Row With Range("E4").CurrentRegion .UnMerge .Clear End With For X = 4 To Ro If Cells(X, 2).MergeCells = True Then t = Cells(X, 2).MergeArea.Rows.Count k = X For y = 1 To t s = s + Cells(k, 3).Offset(y - 1) Next Cells(k, 5).Resize(y - 1).Merge Cells(k, 5) = s s = 0 X = X + y - 2 Else Cells(X, 5) = Cells(X, 3) End If Next X With Range("E4:E" & Roc) .VerticalAlignment = 2 .HorizontalAlignment = 3 .Borders.LineStyle = 1 .Font.Size = 18 .Font.Bold = True End With End Sub الملف مرفق Abd_naser.xlsm

ممكن هذا الشيء تم حماية المعادلات من دون كلمة سر (لعدم العيث بها غن طريق الحطأ) في هذا الملف ABd_sabah_Uniq.xlsx

تصحيح بسيط في المعادلة ( مع Ctrl+Shift +Enter ) INDEX(OUT!B$2:B$100,MAX(IF($A2=OUT!$A$2:$A$100,ROW($A$2:$A$100)-ROW($A$2)+1)))

جرب هذا الماكرو Option Explicit Sub Salim() Dim RoA%, RoB%, i%, a%, b% Dim Rg_B As Range, Rg_A As Range Dim x As Boolean, y As Boolean, z As Boolean Dim Dc As Object RoA = Cells(Rows.Count, 1).End(3).Row RoB = Cells(Rows.Count, 2).End(3).Row Set Rg_B = Range("B2:B" & RoB) Set Rg_A = Range("A2:A" & RoA) Set Dc = CreateObject("Scripting.Dictionary") Range("D2").CurrentRegion.ClearContents i = 2 Do Until i = RoA + 1 If Cells(i, 1) = "" Then GoTo Next_i a = Application.CountIf(Rg_A, Cells(i, 1)) x = a > 1 b = Application.CountIf(Rg_B, Cells(i, 1)) y = b > 0 z = b < a And x And y If z Then Dc(Cells(i, 1).Value) = "" End If Next_i: i = i + 1 Loop If Dc.Count Then Range("D2").Resize(Dc.Count) = _ Application.Transpose(Dc.keys) End If End Sub الملف مرفق Mouhsen.xlsm

للأسف ليس لدي الخبرة الكافية في اليوزر للقيام بهذه المهمة