سليم حاصبيا

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

المعادلة لا تقوم بازاحة الصفوف من مكانها و ريثما تقوم شركة مابكروسوفت باحتراع هكذا معادلة علينا فقط استعمال الــ VBA الكود Option Explicit Sub Get_Std_Names() Dim G As Range Dim H As Range Dim Ro_All%, ro_H%, i%, m%, n% Dim str$ str = "غ" Ro_All = ALL.Cells(Rows.Count, 2).End(3).Row If Farz.Range("b1").CurrentRegion.Rows.Count > 1 Then Farz.Range("b1").CurrentRegion.Offset(1). _ Resize(Farz.Range("b1").CurrentRegion.Rows.Count - 1). _ Clear End If For i = 2 To Ro_All If Application.CountIf(ALL.Cells(i, 3).Resize(, 6), str) = 0 Then m = m + 1 If G Is Nothing Then Set G = ALL.Cells(i, 2).Resize(, 7) Else Set G = Union(G, ALL.Cells(i, 2).Resize(, 7)) End If Else n = n + 1 If H Is Nothing Then Set H = ALL.Cells(i, 2).Resize(, 7) Else Set H = Union(H, ALL.Cells(i, 2).Resize(, 7)) End If End If Next G.Copy Farz.Cells.Cells(2, 2) Farz.Range("a2").Resize(m) = _ Evaluate("Row(" & 1 & ":" & m & ")") H.Copy Farz.Cells.Cells(m + 2, 2) Farz.Range("A" & m + 2).Resize(n) = _ Evaluate("Row(" & 1 & ":" & n & ")") Farz.Range("A2").Resize(m + n). _ Borders.LineStyle = 1 Farz.Range("B1").CurrentRegion.Offset(1). _ Resize(Farz.Range("B1").CurrentRegion.Rows.Count - 1). _ InsertIndent 1 End Sub الملف مرفق Third_class.xlsm

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

هذه المعادلة في B3 و اسحب نزولاً =RIGHT(A3,4)

الكود الصحيح Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("L1")) Is Nothing Then Application.EnableEvents = False Dim code As Integer Dim LB As Object Dim myrow As Range Dim m code = Me.Range("l1").Value Set myrow = Sheets("ورقة1").Range("A:A").Find(what:=code, _ LookIn:=xlValues, lookat:=xlWhole) m = 1 If Not myrow Is Nothing Then For Each LB In ActiveSheet.OLEObjects If TypeName(LB.Object) = "Label" Then LB.Object.Caption = _ myrow.Offset(, m).Value m = m + 1 End If Next Else MsgBox " not found!" End If End If Application.EnableEvents = True End Sub الملف مرفق Copy of Sabry.xlsm

في نهاية الكود اضف هذا السطر كما في الصورة بهذه الطريقة يقوم البرنامج بازالة التكرارات في الصفوف اوتوماتيكياً (دوت ان تشغر بذلك)

1- العامود G يحتوي على معادلات لذلك لا يتعبر الكود خلاياه فارغة 2-لا حاجة الى كل هذا الحلقات التكرارية المدوبلة (على كل خلية في كل صف و كل عامود لفحصها اذا كانت فارغة او لا) 3- الكود المطلوب (بشكل أفضل بدون حلقات تكرارية) تم تغيير اسماء الصفحات الى اللغة الاجنبية (لحسن نسخ الكود ولصقه بدون مشاكل اللغة العربية) Sub salim_cod() Dim lrS%, lrM% Dim S As Worksheet Dim M As Worksheet Dim S_rg As Range, Ful_rg As Range Set S = Sheets("Source"): Set M = Sheets("MW") lrS = S.Cells(Rows.Count, 1).End(3).Row If lrS < 6 Then MsgBox "No Data To Transfer": Exit Sub End If S.Range("A6:F" & lrS).Interior.ColorIndex = xlNone On Error Resume Next Set S_rg = S.Range("A6:F" & lrS).SpecialCells(4) If Not S_rg Is Nothing Then S_rg.Interior.ColorIndex = 35 MsgBox "You have Empty Cells": Exit Sub End If On Error GoTo 0 lrM = M.Cells(Rows.Count, 1).End(3).Row + 1 M.Cells(lrM, 1).Resize(lrS - 5, 7).Value = _ S.Range("A6:G" & lrS).Value Set Ful_rg = M.Range("a5").CurrentRegion If Ful_rg.Rows.Count > 1 Then Set Ful_rg = Ful_rg.Offset(1).Resize(Ful_rg.Rows.Count - 1) With Ful_rg .ClearFormats .Borders.LineStyle = 1 .InsertIndent 1 .Font.Bold = True .Font.Size = 14 .Columns(1).NumberFormat = "dd/mm/yyy" End With End If End Sub الملف مرفق Ahma_Halim.xlsm

الآن استطيع ان اعطيك الكود الصحيح Option Explicit Private Sub Worksheet_Activate() Salim_Data_Val End Sub Rem+++++++++++++++++++ Sub Salim_Data_Val() Dim B As Worksheet Set B = Sheets("البيانات الرئيسية") Dim i#: i = 7 Dim Laste_row# Laste_row = B.Cells(Rows.Count, "N").End(3).Row B.Range("AL7").Resize(Laste_row + 1).ClearContents Dim rg As Object Set rg = CreateObject("System.Collections.Arraylist") With rg Do Until i > Laste_row-6 If Not .Contains(UCase(B.Range("N" & i).Value)) _ And B.Range("N" & i) <> vbNullString Then _ .Add UCase(B.Range("N" & i).Value) i = i + 1 Loop .Sort B.Range("AL7").Resize(.Count) = _ Application.Transpose(.Toarray) End With Set rg = Nothing: Set B = Nothing End Sub

جرب هذا الملف Moustafa Top 10.xlsx

الرّجاء اخباري اي ملف من الاثنين سوف تستعمل

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

بعد اذن احي المهندس جرب هذا الملف (لك حق الاختيار الحد الادنى والاقصى) Alien.xlsx

اذا اردت يمكنك اخفاء العامود حيث نتيجة ( مقبول وغير مقبول ) او يمكن عمل هذا بالماكرو كي بعطبنا فقط الأعمدة المطلوبة الماكرو المطلوب لهذه الحالة Option Explicit '+++++++++++++++++++++++++++++++ Sub transfer_data_ًWithout_J() Dim D As Worksheet Dim Rg As Range Dim arr(), arr_sh() Dim i As Byte, X% Application.ScreenUpdating = False arr = Array("مقبول", "غير مقبول") arr_sh() = Array("المقبولين", "غير المقبولين") Set D = Sheets("DATA"): Set Rg = D.Range("C5").CurrentRegion X = D.Cells(Rows.Count, 3).End(3).Row For i = 0 To 1 Sheets(arr_sh(i)).Range("C5").CurrentRegion.ClearContents Rg.AutoFilter 8, arr(i) D.Range("C5:i" & X).SpecialCells(12).Copy Sheets(arr_sh(i)).Range("C5").PasteSpecial (12) Next D.Select If D.AutoFilterMode Then Rg.AutoFilter Application.ScreenUpdating = True End Sub الملف مرفق للحالتين Mohammed_New.xlsm

اذا لاحظت قمت بفصل الجدول عن بقية البيانات بواسطة صف فارغ (الصف رقم 4) عامود فارغ (العامود B) بهذه الطريفة يتعرّف الاكسل على البيانات التي نريد العمل عليها بمعزل عن باقي خلايا الشيت و بذلك يكون الجدول مستقل عن كل شيء لا يخصّه (بيدأ من الخلية C5 وينتهي عند احر صف غير فارغ) بعرض 8 أعمدة من C الى J كل جدول في اكسل يجب ان يكون بهذه المواصفات (حدوده صف فارغ و عامود فارغ ولا يحتوي على خلايا مدمجة) على فكرة تم ايضا ازالة الخلايا المدمجة من النطاق F5:G5 الخلايا الصفراء أما لماذا استعملت الخلية C5 وليس B5 لان بكل بساطة بعد ما قمت به اصبحت الخلية B5 فارغة

جرب هذا الماكرو Option Explicit Sub Count_My_Colors() Dim lr%, i%, x%, y% lr = Cells(Rows.Count, 5).End(3).Row For i = 1 To lr If Cells(i, 5).Interior.ColorIndex = _ Range("I3").Interior.ColorIndex Then x = x + 1 If Cells(i, 5).Interior.ColorIndex = _ Range("J3").Interior.ColorIndex Then y = y + 1 Next Range("I3") = Switch(x = 0, "Zero", True, x) Range("j3") = Switch(y = 0, "Zero", True, y) End Sub الملف مرفق Dragon.xlsm

ملف احر اكثر توضيحاً (يسمح لك بقص الفواتير كل واحدة منفردة ) و ذلك بوضع صف فارغ تحتها وعامود فارغ الى جانبها) اذا كانت هناك فواتير فارغة لا تطبع Mhd_Sr.xlsm

1-الخلايا المدمجة تعيق عمل اي كود او معادلة تم تغيير تصميم الورقة الثانية بدون خلايا مدمجة 2- تختار من الخلية I2 الرقم الذي سوف يبدأ العمل منه 3- اذا كانت الخلية I2 ليست رقما أو اكبر من اخر رقم في الصفحة الأولى يبدأ العداد من الرقم 1 4- اختر الرقم الذي تريده ثم اضغط على الزر Run الكود Option Explicit Dim s As Worksheet Dim T As Worksheet Dim last As Long, Ro% Dim s_rg As Range Dim i%, K%, My_ro1%, My_ro2%, My_ro% Dim m As Byte, n As Byte, xx As Byte '++++++++++++++++++++++++++++++++ Sub Fatura() Application.ScreenUpdating = False Set s = Sheets("Source") Set T = Sheets("Target") xx = 1 last = s.Cells(Rows.Count, 1).End(3).Row If Val(T.Range("I1")) <= 0 Then i = 1 Else i = Int(Abs(T.Range("I1"))) End If T.Range("I1") = i T.Range("Rg_ALL").ClearContents For K = i + 3 To i + 10 If K > last Then Exit For Select Case xx Mod 8 Case 1: m = 2: n = 2 Case 2: m = 2: n = 4 Case 3: m = 10: n = 2 Case 4: m = 10: n = 4 Case 5: m = 18: n = 2 Case 6: m = 18: n = 4 Case 7: m = 26: n = 2 Case 0: m = 26: n = 4 End Select s.Cells(K, 1).Resize(, 7).Copy T.Cells(m, n).PasteSpecial _ xlPasteValuesAndNumberFormats, Transpose:=True xx = xx + 1 Next Application.CutCopyMode = False Print_Area T.Cells(2, 1).Select Application.ScreenUpdating = True End Sub '+++++++++++++++++++++++++++++++++++ Sub Print_Area() Set T = Sheets("Target") Ro = T.Cells(Rows.Count, 3).End(3).Row For i = 2 To Ro - 6 Step 8 If T.Cells(i, 4) <> "" Then My_ro1 = i + 6 End If Next For i = 2 To Ro - 6 Step 8 If T.Cells(i, 2) <> "" Then My_ro2 = i + 6 End If Next My_ro = Application.Max(My_ro1, My_ro2) T.PageSetup.PrintArea = T.Range("A1:D" & My_ro).Address End Sub الملف مرفق Mhd_Syr.xlsm

بعد اذنك استاذ محمد هناك طريقة أفضل اقترحها في هذا الامر 1- نسخ الملف الثاني الى الأول (بداية من أول خلية فارغة) 2- Remove Duplicates

أولاً - من باب الحرص على الملكية الفكرية يجب عليك ان تذكر صاحب الكود الذي قمت باستعماله ثانيا- لا لزوم اهذه الزركشة من الالوان التي تضخم حجم الملف دون جدوى ثالثاً- انت يقوم بادارج قوائم منسدلة من نطاق AL الذي هو فارغ (انظر الصورة)

1- الصف الثالث من الورقتين(Row 3) يجب ان يكون فارغاً تماماً (لفصل الجدول عن باقي البيانات و بالتالي يتعرّف الاكسل على النطاق الواجب العمل عليه) 2- لا ضرورة للقوائم المنسدلة في ورقة 2 3- تجدد المطلوب من الورقة1 (الخلايا J2 و K2 و L2) ثم الضغط على الزر Run فينتقل المطلوب الى الورقة الثانية 4-في حال كانت اجد الخلايا ( J2 و K2 و L2) او أكثر فارغة (نتكلّم عن الورقة 1) تتم الفلترة على كل البيانات التابعة للخلية (الخلابا الفارعة) مثلا اذا كانت الخلية L2 فارغة تتم الفلترة على كل الفئات (أولى /ثانية / ثالثة) مع الاخذ بالاعتبار الخلايا (J2 و K2) 5- الماكرو Option Explicit Sub Copy_dat() Dim Source_Sheet As Worksheet, Target_Sheet As Worksheet Dim Source_Sheet_rg As Range, Target_Sheet_rg As Range Dim Criterea_rg As Range Dim Where_rg As Range Dim How_many% Set Source_Sheet = Sheets("ورقة1"): Set Target_Sheet = Sheets("ورقة2") Set Source_Sheet_rg = Source_Sheet.Range("A4").CurrentRegion Set Target_Sheet_rg = Target_Sheet.Range("A4").CurrentRegion Set Criterea_rg = Source_Sheet.Range("J1:L2") Set Where_rg = Target_Sheet.Range("A4:J4") How_many = Source_Sheet.Cells(Rows.Count, 3).End(3).Row Target_Sheet.Range("A5:J" & How_many).Clear Source_Sheet_rg.AdvancedFilter 2, Criterea_rg, Where_rg Set Where_rg = Target_Sheet.Range("A4").CurrentRegion How_many = Target_Sheet_rg.Rows.Count If How_many > 1 Then With Where_rg.Offset(1).Resize(How_many - 1) .Borders.LineStyle = 1: .InsertIndent 1 .Font.Size = 14: .Font.Bold = True .Interior.ColorIndex = 35 End With End If End Sub الملف مرفق Advanced_filter.xlsm

تم التعدبل Option Explicit Sub del_zeros_() Dim sh As Worksheet Dim curt As Range Dim rg_to_del As Range Dim F_rg As Range Dim Ro%, i% For Each sh In Sheets If sh.Name Like "report*" Then GoTo next_sheet Ro = sh.Cells(Rows.Count, 1).End(3).Row sh.Range("A4").Resize(, 10) = vbNullString Set curt = sh.Range("E5:I" & Ro) curt.Interior.ColorIndex = xlNone For i = 1 To curt.Rows.Count Set F_rg = curt.Rows(i).Find(0, lookat:=1) If F_rg Is Nothing Then GoTo next_row If rg_to_del Is Nothing Then Set rg_to_del = curt.Rows(i) Else Set rg_to_del = Union(rg_to_del, curt.Rows(i)) End If next_row: Next i If Not rg_to_del Is Nothing Then ' rg_to_del.Delete rg_to_del.Interior.ColorIndex = 35 End If Set rg_to_del = Nothing next_sheet: Next End Sub

جربي هذا الكود Option Explicit Sub del_zeros() Dim sh As Worksheet Dim curt As Range Dim rg_to_del As Range Dim F_rg As Range Dim Ro%, i% Set sh = Sheets("sheet4") Ro = sh.Cells(Rows.Count, 1).End(3).Row If Ro < 5 Then Exit Sub Set curt = sh.Range("E5:I" & Ro) curt.Interior.ColorIndex = xlNone For i = 1 To curt.Rows.Count Set F_rg = curt.Rows(i).Find(0, lookat:=1) If F_rg Is Nothing Then GoTo next_row If rg_to_del Is Nothing Then Set rg_to_del = curt.Rows(i) Else Set rg_to_del = Union(rg_to_del, curt.Rows(i)) End If next_row: Next '+++++++++++++++++++++++++ If Not rg_to_del Is Nothing Then ' rg_to_del.EntireRow.Delete rg_to_del.Interior.ColorIndex = 6 End If Set rg_to_del = Nothing End Sub الكود يقوم بتلوين الصقف المطلوب اذا اردت حذفها استبدلي ما موجود في المربع المربع الأجمر بما هو موجود في المربع الأزرق (الصورة)

ليست المرة الأولى التي اقول فيها يجب رفع ملف فيه بيانات لا أوراق فارغة

كل ما هو سطر Dim يكون متغير

لماذا كل هذا العمل المرهق طالما الملف الاولي بياناته كاملة فقط امسح كل شيء من الملف الثاني و اعمل مكانها نسخة عن بيانات الملف الأول (Copy Paste) او احذف نهائياً الملف الثاني و اعمل نسخة ثانية عن الأول وقم بتسمتها باسم جديد كما تريده