سليم حاصبيا

ليست المرة الاولى التي اذكر بأنه ليس من الضرورة ادراج بيانات كبيرة (اكثر من 5000 صف) لأن الماكرو الذي يعمل على خلية واحدة يستطيع العمل على الوف الالوف منها Sub Row_to_column() Dim Ro%, I%, m%, K% With Sheets("MAIN") Ro = .Cells(Rows.Count, 1).End(3).Row .Range("C2", Range("E1").End(4)).ClearContents m = 2 For I = 2 To Ro Step 3 For K = 0 To 2 .Cells(m, 3).Offset(, K) = _ .Cells(I, 1).Offset(K) Next K m = m + 1 Next I End With End Sub الملف مرفق TAKSIM_TO COL.xlsm

أولاً- لا ادري ما الغاية من دمج الخلايا (من A الى J ) في خلية واجدة كما في الصورة الأولى ثانياُ يجب حذف المسافة الزائدة بين كلمة الأهداف والنقطتين (الاهداف ؟؟ 🙂 List_box50.xlsm

جرب هذا النموذج (و حاول تطبيقه على الملف عندك) Days.xlsx

أولاً- للمرة الثانية أقول لك لا حاجة الى Select و Selection التي ترهق البرنامج دون فائدة خاصة ان الييانات كثيرة 40000 الف خلية (من G2 الى J10000 ) ثانياُ - اذا كنت تريدين مسح كل شيء يكفي كود من سطر واحد Sub ClearData() Sheets("Sheet1").Range("G2:L10000").Clear End Sub

The correct Code Select Not Needed Sub ClearData() With Sheets("Sheet1").Range("G2:L10000") .Borders.LineStyle = xlNone .ClearContents End With End Sub

تمت الاجابة عن هذا السؤال في مشاركة سابقة كان يجب ادراج هذا الامر فيها تم التعدبل للحصول على كل الحبارات Option Explicit Dim A As Worksheet, B As Worksheet, C As Worksheet Dim Rg_A As Range, Rg_B As Range, Rg_c1 As Range Dim LA%, LB%, LC% Dim Found_range As Range Dim I%, M% '++++++++++++++++++++++++++ Sub Dedut() Set A = Sheets("List_A") Set B = Sheets("List_B") Set C = Sheets("List_C") LA = A.Cells(Rows.Count, 1).End(3).Row LB = B.Cells(Rows.Count, 1).End(3).Row Set Rg_A = A.Range("A1:a" & LA) Set Rg_B = B.Range("A1:a" & LA) End Sub '++++++++++++++++++++++++++++++++ Sub In_A_not_In_B() Dedut M = 2 LC = C.Cells(Rows.Count, 3).End(3).Row If LC > 1 Then C.Range("C2:C" & LC).ClearContents End If For I = 1 To LA If A.Range("A" & I) <> vbNullString Then If Application.CountIf(A.Range("A1:A" & I), A.Range("A" & I)) = 1 Then Set Found_range = Rg_B.Find(A.Range("A" & I), lookat:=1) If Found_range Is Nothing Then C.Cells(M, 3) = A.Range("A" & I) M = M + 1 End If End If End If Next End Sub '+++++++++++++++++++++++++++++++++++ Sub In_B_not_In_A() Dedut M = 2 LC = C.Cells(Rows.Count, 5).End(3).Row If LC > 1 Then C.Range("E2:E" & LC).ClearContents End If For I = 1 To LB If B.Range("A" & I) <> vbNullString Then If Application.CountIf(B.Range("A1:A" & I), A.Range("A" & I)) = 0 Then Set Found_range = Rg_A.Find(B.Range("A" & I), lookat:=1) If Found_range Is Nothing Then C.Cells(M, 5) = B.Range("A" & I) M = M + 1 End If End If End If Next End Sub '++++++++++++++++++++++++++++++++++++++ Sub In_A_And_B() Dedut M = 2 Dim dic As Object Set dic = CreateObject("Scripting.Dictionary") LC = C.Cells(Rows.Count, 7).End(3).Row If LC > 1 Then C.Range("G2:G" & LC).ClearContents End If For I = 1 To LA If A.Range("A" & I) <> vbNullString Then dic(A.Range("A" & I).Value) = A.Range("A" & I).Value End If Next For I = 1 To LB If B.Range("A" & I) <> vbNullString Then dic(B.Range("A" & I).Value) = A.Range("A" & I).Value End If Next If dic.Count Then C.Cells(M, 7).Resize(dic.Count).Value = _ Application.Transpose(dic.Keys) End If End Sub '+++++++++++++++++++++++++++++ Sub Not_common() Dedut M = 2 Dim dic As Object Set dic = CreateObject("Scripting.Dictionary") LC = C.Cells(Rows.Count, "I").End(3).Row If LC > 1 Then C.Range("I2:I" & LC).ClearContents End If For I = 1 To LA If A.Range("A" & I) <> vbNullString And _ Application.CountIf(Rg_B, A.Range("A" & I).Value) = 0 Then dic(A.Range("A" & I).Value) = A.Range("A" & I).Value End If Next For I = 1 To LB If B.Range("A" & I) <> vbNullString And _ Application.CountIf(Rg_A, B.Range("A" & I).Value) = 0 Then dic(B.Range("A" & I).Value) = B.Range("A" & I).Value End If Next If dic.Count Then C.Cells(M, 9).Resize(dic.Count).Value = _ Application.Transpose(dic.Keys) End If End Sub '+++++++++++++++++++++++++++++ Sub common() Dedut M = 2 Dim dic As Object Set dic = CreateObject("Scripting.Dictionary") LC = C.Cells(Rows.Count, "K").End(3).Row If LC > 1 Then C.Range("K2:K" & LC).ClearContents End If For I = 1 To LA If A.Range("A" & I) <> vbNullString And _ Application.CountIf(Rg_B, A.Range("A" & I).Value) > 0 Then dic(A.Range("A" & I).Value) = A.Range("A" & I).Value End If Next For I = 1 To LB If B.Range("A" & I) <> vbNullString And _ Application.CountIf(Rg_A, B.Range("A" & I).Value) > 0 Then dic(B.Range("A" & I).Value) = B.Range("A" & I).Value End If Next If dic.Count Then C.Cells(M, 11).Resize(dic.Count).Value = _ Application.Transpose(dic.Keys) End If End Sub الملف من جديد Names_allVarinat.xlsm

في المرفق 3 ماكرو اختر ما تريد للنشغيل Names.xlsm

code Private Sub UserForm_Initialize() Dim lrc, lrb, My_Formula lrc = Sheets("Sheet1").Cells(Rows.Count, 3).End(3).Row lrb = Sheets("Sheet1").Cells(Rows.Count, 2).End(3).Row My_Formula = "=SUM(C2:C" & lrc & ")-SUM(B2:B" & lrb & ")" My_Formula = Evaluate(My_Formula) Me.TextBox1 = My_Formula End Sub

مين تقصد لحضرتك انا او الاستاذ خيماوي

اذا كنت قد فهمتك صحيحاً فالحل هنا More_Condidtions.xlsx

هذا الكود Option Explicit Sub RANDOM_INDEX() Dim n%, x%, i% Dim m%, y%, z%, T% Dim My_rg As Range Dim colL As Collection Set My_rg = Sheets("Main").Range("B11:B14") Set colL = New Collection y = 1: z = My_rg.Columns(1).Rows.Count: n = 1 With CreateObject("System.Collections.SortedList") Do Until .Count = z T = Rnd x = Int((z - y + 1) * Rnd()) + y .Item(x) = n On Error Resume Next colL.Add x, CStr(x) On Error GoTo 0 n = n + 1 Loop m = 5 For i = 0 To .Count - 1 Sheets("hamed").Cells(2, m) = _ My_rg.Cells(colL(i + 1)) m = m + 1 Next End With End Sub الملف مرفق Hamed_Rand.xlsm

أولاُ لم افهم عليك ما تريد ثانياُ في اي صفحة تريد العمل ثالثاً ارقع ملف يحنوي على النتيجة التي تتو قعها (مثال عما تريد) (اكتب البيانات والتتائج يدوياً)

هذه المعادلة =LOOKUP(MAX(ورقة2!$B$1:$B$100)+1,ورقة2!$B$1:$B$100,ورقة2!$B$1:$B$100) salman.xlsx

هذا الكود Sub button1_click() Dim last_E% Dim last_L% Dim col%, i% Dim E As Worksheet Dim L As Worksheet Set E = Sheets("entry") Set L = Sheets("list") last_E = E.Cells(Rows.Count, "L").End(3).Row last_L = L.Cells(Rows.Count, 2).End(3).Row + 2 col = 15 For i = 3 To last_L If Application.CountA(E.Cells(i, "L").Resize(, col - 1)) <> 0 Then L.Cells(last_E, 2).Resize(, col - 1).Value = _ E.Cells(last_E, "L").Resize(, col - 1).Value End If Next E.Range("L3:y" & last_E) = vbNullString End Sub

الأفضل رقع ملفات بدون زركشة الوان (اسهل على المتابعة) مبدئياً هذا الكود (يتحاهل النصوص والفراغات) Sub sum() Dim mr As Worksheet Dim lr%, i%, x% Set mr = Sheets("mark-s") With mr lr = .Range("c" & Rows.Count).End(xlUp).Row For i = 9 To lr For x = 12 To 103 Step 13 With .Cells(i, x) .Value = _ Val(.Offset(, -3)) + _ Val(.Offset(, -2)) + _ Val(.Offset(, -1)) End With Next x Next i End With End Sub

الكود الصحيح Sub button1_click() Dim last_E As Integer Dim last_L As Integer Dim col% last_E = Sheets("entry").Cells(Rows.Count, "K").End(3).Row last_L = Sheets("list").Cells(Rows.Count, 1).End(3).Row + 1 col = 15 Sheets("list").Cells(last_E, 1).Resize(last_E - 2, col).Value = _ Sheets("entry").Cells(3, "K").Resize(last_E - 2, col).Value End Sub hamdy.xlsm

أولاً - الخطأ في هذه العبارة Range("A10:A12").Select لأنك أخفيت العامود A فكبف تريد ان تحدد خلايا منه؟؟؟؟ ثانباً - لا داعي لهذه الكمية من الأوامر Select التي لا حاجة لها ضع النطاق الدي تريده في المريع الأحمر فقط ونفذ الكود (الصورة) ولك الحيار في Protect و Unprotect

جرب تغيير اسم الملف مثلاً: My_File.xlsm

حرب هذا الملف (تم اعادة نسمية الأوراق باللغة الأجنبية لحسن عمل المعادلات) CONARS_1.xlsx

ألوان فاقعة وخلايا مدمجة (لأ استطيع العمل على هكذا ملف) أعتذر

عندي عادة في الأكواد لا استعمل اللغة العربية لذلك استبدل المربع الأحمر بالمربع الأزرق (الصورة) الملف مرفق happy_New.xlsm

ممناز استاذ ابراهيم لكن كي لا تكون النتيجة بشكل تاريخ بوجود علامة "/" مثلاً jun 02 يجب ادراح السطر في المربع الأحمر من الصورة

المعادلة =MAX($J$2:$K$2)-MIN($J$2:$K$2)+1

تم التعديل Option Explicit Dim lr% Dim How_many Dim Sh As Worksheet Dim i%, k%, x '+++++++++++++++++++++++++++++++ Sub Begining() Set Sh = Sheets("Media") lr = Sh.Cells(Rows.Count, 2).End(3).Row If Val(Sh.Cells(1, "k")) < 1 _ Or Sh.Cells(1, "k") > lr - 1 Then How_many = 10 Else How_many = Int(Sh.Cells(1, "k")) End If Sh.Cells(1, "k") = How_many End Sub '+++++++++++++++++++++++++++++++ Private Sub cmd_reset_Click() Me.ListBox1.Clear UserForm_Initialize End Sub '++++++++++++++++++++++++++++++++++++ Private Sub Cmd_Show_Click() Begining Dim t: t = 1 If lr < How_many + 1 Then Exit Sub x = lr - How_many + 1 With Me.ListBox1 .Clear .AddItem .List(.ListCount - 1, 0) = "Count" .List(.ListCount - 1, 1) = Sh.Cells(1, 2) .List(.ListCount - 1, 2) = Sh.Cells(1, 3) For k = x To lr .AddItem .List(.ListCount - 1, 0) = t t = t + 1 For i = 1 To .ColumnCount - 1 .List(.ListCount - 1, i) = _ Sh.Cells(k, i + 1) Next i Next k End With Me.Cmd_Show.Caption = _ "Laste " & How_many End Sub '+++++++++++++++++++++++++++++++ Private Sub UserForm_Initialize() Begining With Me.ListBox1 .AddItem .List(.ListCount - 1, 0) = "Count" .List(.ListCount - 1, 1) = Sh.Cells(1, 2) .List(.ListCount - 1, 2) = Sh.Cells(1, 3) .List(.ListCount - 1, 4) = "" For k = 2 To lr .AddItem .List(.ListCount - 1, 0) = k - 1 For i = 1 To .ColumnCount - 2 .List(.ListCount - 1, i) = _ Sh.Cells(k, i + 1) Next i Next k End With Me.Cmd_Show.Caption = _ "All Are Showing" End Sub الملف مرفق Ali_listbox.xlsm

الصفحة يحب ان يبدو هكذا (الصورة) ( الصفحة test من هذا الملف) (ثم لماذا لا نستطيع التحرك في الصفحة M1 لرؤية الخلية A100 مثلاً) ABC.xlsx