سليم حاصبيا

ربما ينفع هذا الكود Option Explicit Sub Copy_range() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim My_max%: My_max = Application.Max(Sheets("الربط").Range("f:f")) + 5 Sheets("العمليات").Range("f5").Resize(500, 54).ClearContents Sheets("الربط").Range("f5").Resize(My_max, 54).Copy _ Sheets("العمليات").Range("f5") With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف مرفق Omra.xlsm

ممكن هذا الحل باستعمال شيت مساعد (الملف مرفق) الماكرو Option Explicit Sub Pprint_Sames_columns() Dim xRg Dim arr Dim i%, r%, m%: m = 1 r = Sheets("salim").Range("a1").CurrentRegion.Rows.Count Sheets("Print_sheet").Cells.Clear xRg = Application.InputBox(" أكتب أرقام الأعمدة مع فاصلة بين كل رقم والذي يليه", "المطلوب أرقام الأعمدة", Type:=2) arr = Split(xRg, ",") For i = LBound(arr) To UBound(arr) If IsNumeric(arr(i)) Then Sheets("salim").Cells(1, Int(CInt(arr(i)))).Resize(r).Copy _ Sheets("Print_sheet").Cells(1, m) m = m + 1 End If Next Sheets("Print_sheet").PrintPreview End Sub Print Same Colmns.xlsm

تمت الاجابة على هذا العنوان https://www.officena.net/ib/topic/90797-كيف-نجعل-الكود-يعمل-على-كل-العمود/?tab=comments#comment-569785

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

لاستعمال الدالة vlookup بدون اخر Argument بجب ان تكون البيانات(BAREME!$F$4:$I$24) مرتبة تصاعديا Mouraqaba.xlsx

كيف العمل مع شيت محمي بواسطة كلمة سر (بعد ان تضيع حوالي نصف ساعة من الوقت لوضع كود يلائم ما يريده صاحب السؤال تتفاجأ بوجود كلمة سر) للمرة الأخيرة اقول للجميع اي ملف يرفع مع باسيورد سوف أقوم باهماله و حذف المشاركة الخاصة به

ربما كان المطلوب mratab.xlsm

ربما كان المطلوب الكود لا يعمل الا اذا كان الصف كاملاً 5 عناصر Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Not Intersect(Target, Range("A7:E200")) Is Nothing _ And Target.Cells.Count = 1 Then Range("F7:F200").Formula = "=IF(COUNTA($A7:$E7)<5,"""",E7*C7)" Range("F7:F200").Value = Range("F7:F200").Value End If Application.EnableEvents = True End Sub الملف مرفق fatoura2.xlsm

استبدل الرقم1 بالرقم 2 في هذا السطر من الكود Set my_rg = Main.Range("b3").CurrentRegion.Columns(1)

كود لاضافة اسم جديد (دون تكرار) Option Explicit Sub ad_to_list() With Sheets("Salim") Dim st$, Lr% Lr = .Cells(Rows.Count, 1).End(3).Row st = InputBox("Write the new name", "salim tell you", "New_Name") If Application.CountIf(.Range("b10:b" & Lr), st) <> 0 Then MsgBox "this name is Alraedy exist": Exit Sub Else .Range("b" & Lr + 1) = st: .Range("a" & Lr + 1) = .Range("a" & Lr) + 1 End If End With End Sub الملف مرفق Mourattabat_New_Name.xlsm

بعد اذن اخي مصطفى هذا الملف الكود Option Explicit Sub Give_data() With Sheets("Salim") Dim my_cel As Range Dim Date_Rg As Range Dim laste_row%, ro%, col Dim sRg As Range laste_row = .Cells(Rows.Count, 1).End(3).Row col = Application.Count(Range("c9:ag9")) Set Date_Rg = .Cells(9, 3).Resize(, col) For Each my_cel In Date_Rg If my_cel.Offset(-1) <> vbNullString Then Set sRg = .Range("a9:a" & laste_row).Find([a6], lookat:=xlWhole) If Not sRg Is Nothing Then ro = sRg.Row .Cells(ro, my_cel.Column) = my_cel.Offset(-1) Else MsgBox "This Record Is Not Found": Exit Sub End If End If Next End With End Sub الملف مرفق مع الشرح الوافي Mourattabat.xlsm

و ما هي جملة المتغيراتج

يا اهي الملف يحتوي على اكثر من شيت اي شيت تريد ان تعمل عليه؟؟؟؟

لم توضح في اي ورقة تريد ان يعمل الكود ارفع ملف صغير من ورقة واحدة توضح فيها المطلوب

ارفع ملف توضح فيه المطلوب

انا مش بقول لا تستعملها بل حاول ان تتجنبها قدر الامكان بوجود عدة دالات مثل Find & FindNext مثلاً او من خلال Filter & advanced filter

صديقي مصطفى رداً على رغبتك بتقييم الملف 1- قدر الامكان يحب الابتعاد عن الحلقات التكرارية وخاصة اذا كانت تتجاوز 1000 صف في كل تغيير لحرف واحد في الليست بوكس 2- اما و قد فرضت علينا الحلقات التكرارية فلا بد من التقليل منها 3- في هذا التعديل للكود يتم تخفيض عدد الحلقات التكرارية 6 أضعاف ( كانت 1700 عدد الصفوف × 6 عدد الاعمدة)=حوالي 10.000 دورة وأكثر لكن بالتعديل الذي أجريته لك (ما بين علامات +++++++) بعد الغاء الحلقة التكرارية J يعود عدد دروات الحلقات التكرارية الى 1700 4 - أنصج دائماً ياستعمال الخاصيىة Option Explicit في رأس كل كود لضبط كل انواع الأخطاء 5- يمكن استعمال الفلتر المتقدم لهذا الغرض أفضل من الحلقات التكرارية 6 - و اخيراً الكود معدلاً (مع الملاجظة ان يبدأ العدد h من الرقم 6 و SH.Range("A6:F10000").ClearContents حتى لا يتغير رأس الجدول الكود بعد التعديل Private Sub TextBox1_Change() Dim WS As Worksheet: Set WS = Sheets("salim") Dim SH As Worksheet: Set SH = Sheets("تقرير") Set f = WorksheetFunction '+++++++++++++++++++++++++++++++ SH.Range("A6:F10000").ClearContents h = 6 '++++++++++++++++++++++++++++++++++++ lr = WS.Range("C" & Rows.Count).End(xlUp).Row For i = 5 To lr On Error Resume Next m = Len(TextBox1) a = 0 a = f.Search(TextBox1, Left(WS.Cells(i, 3), m)) If a > 0 Then '+++++++++++++++++++++++++++++++++++++++++ SH.Cells(h, 1).Resize(, 6).Value = _ WS.Cells(i, 1).Resize(, 6).Value h = h + 1 ''''''''''''''''For j = 1 To 9 ''''''''''''''''SH.Cells(h, j) = WS.Cells(i, j) ''''''''''''''''Next j '++++++++++++++++++++++++++++++++++++++++++++ End If Next i End Sub الملف من جديد Wared_Mustafa.xlsm

هذا الماكرو ربما ينفع (الملف مرفق) Private Sub CommandButton1_Click() Dim My_Rg As Range Set My_Rg = Sheets("ورقة1").Range("c5:j24") Dim x%: x = 1 Dim i%, j% For j = 1 To My_Rg.Columns.Count For i = 1 To My_Rg.Rows.Count Me.Controls("TextBox" & x).Value = My_Rg.Cells(i, j).Value x = x + 1 Next Next End Sub data To user.xlsm

انا لم أر اي خطأ مع ذلك تم تحديث البرنامج ليبدو أكثر وضوحاً 1-الأصناف تظهر مرتبة ابجدياُ 2- تلوين الوارد بلون والمنصرف بلون أخر 3-تعليم صفوف الشبكة حيث يوجد بيانات 4- اذا كانت كمية الوادر او المنصرف تساوي صفر لا تظهر في التقرير 5-تمييز صف المجاميع بلون مختلف عسى أن ينال الاعجاب لا استطيع التحسين أكثر من هذا special_data_sorted.xlsm

ممكن ان يكون المطلوب 1-ليس عليك الكتابة (مخافة الوقوع بأخطاء املائية أو مسافات زائدة أو ناقصة وتوفيراً للوقت) 2 اختر الاسم الذي تريد من الكومبو الذي ياخذ معطياته من شيت salim دون تكرار 3- لتحديث البيانات في شيت salim اضغط على الزر "هات ما عندك" special_data.xlsm

بعد اذن اخي علي الترتيب يتم في العامود الثاني مما يسبب مشاكل في بقية البيانات في الاعمدة المتبقية (مثلا تاريخ ميلاد محمد كان 1/3/2015 فاصبح 10/12/2009) لذلك اقترج هذا الكود 1- يتم الترتيب ابتداء من العامود 2 و حتى العامود 10 (حيث لا يتم المس بالترقيم الالي في العامود الاول) 2 - الترقيم اوتوماتيكي يرجى عدم الترقيم (تم وضع حماية له) 3- لا يتم الترتيب الا اذا كتمل الصف بـــــ 10 عناصر الكود Private Sub Worksheet_Change(ByVal Target As Range) Dim rw%, x%, lr%: rw = 8 x = Application.CountA(Range(Cells(Target.Row, 1), Cells(Target.Row, 10))) If Target.Row > rw And Target.Column <= 10 And x = 10 Then lr = Cells(Rows.Count, 1).End(3).Row Cells(rw, 2).Resize(lr, 9).Sort _ Key1:=Cells(rw, 2), _ Order1:=1, Header:=2 End If End Sub الملف مرفق Sort_data.xlsm

تم معالجة الامر TAGs.xlsx

جرب ما يلي cond_talween.xlsx

يا اخي اكتب الأوقات التي تريدها يمكن ان يخرج الموظف من عمله قبل انتهاء الدوام مثلا دخول الساعة (08:00) خروج الساعة (10:00) الكود يستخرح أول وقت واخر وقت مهما كان عدد الاوقات