سليم حاصبيا

تم معالجة الامر (بواسطة ارقام الخلايا في عامود الاسماء) فقط اكتب البداية في الخلية H4 والنهاية في الخلية H5 في الشيت "sew sheet" واضغط الزر Run لا حاجة لكتابة الاسماء في الماكرو السايق (فقط من اسم كذا الى اسم كذا) حسب الجدول الكود Option Explicit Sub Print_out() With Application .ScreenUpdating = False .EnableEvents = False .DisplayAlerts = False .Calculation = xlCalculationAutomatic End With Dim S_Sh As Worksheet: Set S_Sh = Sheets("DATA") Dim Targ_sh As Worksheet: Set Targ_sh = Sheets("Sew_Sheet") Dim x%, y%, t1%, t2%, i% Targ_sh.Unprotect x = Targ_sh.[h4]: y = Targ_sh.[h5] t1 = Application.Min(x, y): t2 = Application.Max(x, y) If t1 <= 1 Then t1 = 2 For i = t1 To t2 Targ_sh.Cells(3, 2) = S_Sh.Range("a" & i) '======================================= 'Choose Here print Or print previvew Targ_sh.PrintPreview ' Targ_sh.PrintOut '========================================= Next With Application .ScreenUpdating = True .EnableEvents = True .DisplayAlerts = True .Calculation = xlCalculationAutomatic End With Targ_sh.Protect End Sub الحد الأقص Salim new.xlsm

كل ما عليك فعله هو التتغيير في هذين السطرين الارقام هي ارقام الاعمدة المراد نسخها A=1,B=2,G=7 , وهكذا الرقم 6 هو عدد العناصر في a ناقص واحد

يجب وصع الماكرو في موديل مستقل و ليس في الوورك شيت لذلك امسحه من مكانه و ضعه في موديل مستقل

بمكنك استعمال هذا الماكرو ( في احر سطرين قبل Next اختر او طباعة او معاينة قبل الطباعة) و ذلك بحذف الفاصلة العليا أمام ما تريد عند تنقيذ الماكرو تظهر لك رسالتين الرسالة الاول ابتداءً من الاسم (الاول) الرسالة الثانية حتى الاسم (الاخير) تضع الاسم من الجدول تماماً كما هو دون مسافات زائدة او ناقصة (الافضل اخذ الاسم Copy / Paste) لا مشكلة في الترتيب (اذا كان اول اسم مثلاُ رقمه 15 والثاني 5) اكسل يرتبها بحيث يكون الاول 5 والثاني 15 Option Explicit Sub Print_out() Dim S_Sh As Worksheet: Set S_Sh = Sheets("DATA") Dim Targ_sh As Worksheet: Set Targ_sh = Sheets("Sew_Sheet") Dim x%, y%, t1%, t2%, i% Dim First_Name$, Second_Name$ First_Name$ = Application.InputBox("give the first name", Type:=2) Second_Name = Application.InputBox("give the seconde name", Type:=2) First_Name = Application.Trim(First_Name) Second_Name = Application.Trim(Second_Name) x = Application.Match(First_Name, S_Sh.Range("a:a"), 0) y = Application.Match(Second_Name, S_Sh.Range("a:a"), 0) t1 = Application.Min(x, y): t2 = Application.Max(x, y) For i = t1 To t2 Targ_sh.Cells(3, 2) = S_Sh.Range("a" & i) '======================================= 'Choose Here print Or print previvew ' Targ_sh.PrintPreview ' Targ_sh.PrintOut '========================================= Next End Sub

جرب هذا الملف(لعله المطلوب) ADD_SHEETS.xlsm

فيديو مماثل و بتفاصيل اكثر على هذا العنوان https://www.youtube.com/watch?v=IZLAzIYfMDU

بعد اذن اخي شريغ هذا الكود (يمكن ان يكون اسرع قليلاُ) Option Explicit Sub Filter_For_Me() With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual End With On Error GoTo Exit_sub Dim i% Dim t% Dim arr(): arr = Array("م", "غ", "<50", "صفر") Dim My_Rg As Range Dim FinaL_row%: FinaL_row = Sheets("data").Cells(Rows.Count, 2).End(3).Row Set My_Rg = Sheets("data").Range("b2:M" & FinaL_row) For i = 2 To Sheets.Count With Sheets(i) .Range("a2:M1000").Clear .Range("Xfd1") = .Name .Range("xfd2").Resize(4, 1) = Application.Transpose(arr) My_Rg.AdvancedFilter Action:=2, _ CriteriaRange:=.Range("xfd1:xfd5"), _ CopyToRange:=.Range("a2"), Unique:=False .Range("a1").CurrentRegion.Columns.AutoFit .Range("xfd1:xfd5").Clear For t = 12 To 5 Step -1 If .Cells(2, t) <> .Name Then .Cells(2, t).EntireColumn.Delete Next t End With Next i Exit_sub: With Application .ScreenUpdating = True .EnableEvents = True .Calculation = xlCalculationAutomatic End With Erase arr End Sub الملف مرفق استدعاءبشروط Salim1.xlsm

في هذا الملف خياران كل في صفحة (Salim / Salim(2 اختر ما تريد 11salim2.xlsx

هل اطلعت على الصفحة Salim من الملف الاخير الذي رفعته لك

تم معالجة الامر (صفحة SALIM) 11salim1.xlsx

يمكن ان يكون المطلوب 11salim.xlsx

الملف مرفق رقم الصفوف لكلمة salim.xlsm

هذه المعادلة مع ( Ctl+Shift+Enter و ليس Enter وجدها) ,واسحب نزولاً =IF(ROWS($A$1:A1)>COUNTIF($B$3:$B$50,$C$2),"",SMALL(IF($B$3:$B$50<>"",IF($B$3:$B$50=$C$2,ROW($B$3:$B$50)-ROW($B$3)+3)),ROWS($A$1:A1)))

اذا كانت مجموع ديونه يساوي ضفر فلا يدرج اسمه تلقائياً

السلام عليكم هل تريد انشاء لائحة باسماء الزبائن مرتبة حسب قيمة مجموع الديون على كل شخص(ترتتيب تنازلي) ؟ (اسماء الزيائن يمكن ان تكون مكررة اكثر من مرة و كذلك قيمة الديون) اكسل يفعلها بواسطة المعادلات Name_list by Sum.xlsx

جرب هذه المعادلة في الخلية G2 واسحب يساراً 5 أعمدة ثم نزولاً قدر ما تريد =INDEX($N$2:$N$6,COLUMNS($A$1:A1))

لعلك نستعمل اصدار اقل من 2010 لذلك اليك هذا الملف 2003 لعله لا يجدث عندك خطأ ترتيب عشوائي SALIM.xls

جرب هذا الملف الكود Option Explicit 'Excel VBA to generate random number 'Created by Salim on 31/3/2018 Sub Generate_Uniq_Random() Dim T% If ActiveSheet.Name <> "Salim" Then GoTo Exit_sub With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim myStart As Long Dim myEnd As Long Dim x As Byte Dim i As Long, K% Dim lr_B: lr_B = Range("A1").CurrentRegion.Rows.Count If lr_B < 2 Then lr_B = 2 Range("b2:U" & lr_B).ClearContents Dim a() myStart = [Y2] myEnd = [Z2] ReDim a(0 To myEnd - myStart) For x = 2 To 21 With CreateObject("System.Collections.SortedList") Randomize For i = myStart To myEnd .Item(Rnd) = i Next i For i = 0 To .Count - 1 a(i) = .GetByIndex(i) Next For K = 2 To lr_B - 1 Step (myEnd - myStart + 1) For T = 0 To myEnd - myStart Cells(K + T, x) = a(T) Next Next End With Next Exit_sub: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف مرفق ترتيب عشوائي SALIM.xlsm

ارفع الملف لمعرفة الخطأ (اذ لا يمكن التخمين)

استبدل الكود بهذا Sub tarhil() Dim I, m%: m = 2 Dim Rs%: Rs = Source.Cells(Rows.Count, 3).End(3).Row Dim Rt%: Rt = Targ.Cells(Rows.Count, 3).End(3).Row If Rt < 2 Then Rt = 2 Targ.Range("b2:c" & Rt).Clear For I = 2 To Rs With Source If .Range("c" & I).Interior.ColorIndex = 6 Then .Range("B" & I) = "متفوق" .Cells(I, 3).Offset(0, -1).Resize(1, 2).Copy Targ.Cells(m, 2) m = m + 1 End If End With Next End Sub

لم افهم شيئاً الافضل (ارفاق جزء من الملف اذا كان كبيراً)

لم افهم ماذا تعني بهذا النطاق ال محتاجه يحسب عدد صفحاته هو من (A1:ET50000) و هل تريد ان تحذف الصفحات الموجودة (ما عذا الصفحة الاولى) قبل تنفيذ الكود

ربما تقصد هذا الماكرو Option Explicit Sub insert_sheets() On Error GoTo Exit_Sub Worksheets.Add after:=Sheets(Sheets.Count), Count:=[a1].Value Exit_Sub: End Sub

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

يبدو ان هذا ما تريد OSOL3 salim1.xls