سليم حاصبيا

السبب في ذلك اني وضعت المعادلات في الشيت Sapace لغاية الصف 495 على 4 اعمدة (اي حوالي 2000 معاجلة ) و مثلهم في الصفحة النتيجة فيصبح عندنا 4000 معادلة على اكسل ان ينفذها مع كل كبسة على اي زر في الكيبورد فما بالك لو كان هناك 15000 صف (يكون الحاصل 120 الف معادلة ) مما يسبب ثقل كبير في الملف و بطء بالتنفيذ اليك مثال عما أعنيه (ملف 20.000 صف) اصبح حجمه 2.6 ميغا (هنا الحجم لا يهم بل الأهمية للوقت في تنفيذ المعادلات) لذلك انصح بعدم القيام بهذا العمل من خلال Excel بل من خلال برنامج مخصص لهذه الاشياء Access مثلا Company_Tel_New.xlsm

تم العمل بواسط الماكرو انظر الى الصفحة salim من هذا الملف الكود Option Explicit Sub find_FirstAndLast_Time() If ActiveSheet.Name <> "salim" Then Exit Sub Dim objReg As Object Dim Match Dim objMatches As Object Dim a, i, y%: y = 1 Dim arr() Dim m%: m = 2 Range("D2:e5000").ClearContents Set objReg = CreateObject("vbscript.regexp") With objReg .IgnoreCase = False .Global = True .Pattern = "(\d{2}:\d{2})" End With Do Until Range("c" & m) = vbNullString '============================================ Set objMatches = objReg.Execute(Range("c" & m)) If objMatches.Count = 0 Then GoTo Next_m For Each Match In objMatches a = Match.Submatches.Count For i = 0 To a - 1 ReDim Preserve arr(1 To y) arr(y) = Match.Submatches.Item(i) y = y + 1 Next Next Range("D" & m) = arr(1): Range("E" & m) = arr(y - 1) Erase arr: y = 1 Next_m: m = m + 1 '============================================ Loop Set objReg = Nothing End Sub الملف مرفق BASMA.xlsm

مع اني لا أعمل في مجال اليوزر فورم ومشتقاته وليس لدي الخبرة الكافية بأكواده اقترح هذا الكود دون الحلقات التكرارية Option Explicit Private Sub Commandbutton4_Click() Dim lr% Sheets(17).Cells(5, 1).Resize(Me.ListBox1.ListCount, Me.ListBox1.ColumnCount) = _ Me.ListBox1.List lr = Sheets(17).Cells(Rows.Count, 1).End(3).Row Sheets(17).Cells(lr + 3, 1).Resize(Me.ListBox2.ListCount, Me.ListBox2.ColumnCount) = _ Me.ListBox2.List End Sub

1-هناك تاريخان واحد في الوارد واخر في المنصرف فأي تاريج تريد ان يدرج في ورقة النتيجة 2- البيانات كبيرة جداً في الملف (مما يصعب عملية تتبع الكود) لذلك قم بتحميل ملف مختصر (10 الى 15 صف فقط ) في كل من الوارد والمنصرف مع البيانات اللازمة و عندما نجد الكود المناسب يتم تعميمه على الملف الاصلي

قم بالترتيب في أوراق المصدر ثم نفذ الكود فيظهر لك كل شيء كما تريد

جرب هذا الملف في المرة المقبلة قم بتحميل ملف مختصر عما تريد ( من 10 الى 15 صف فقط) و ذلك للقدرة على مراقية عمل المعادلات من حهة ومن خهة ثانية تخفيفاُ لحجم الملف و اذا كان كل شيء كما تريد تقوم بتعميم المغادلات على كامل الملف الاصلي الاجابة في صفحة Salim Company_Tel.xlsm

بيانات الوارد مختلفة عن المنصرف لذلك من الصف الاول حتى 107 الوارد (المصدر ورقة الوارد) باللون الأحمر و من 109 الى الاخر المنصرف (المصدر ورقة المنصرف ) باللون العادي هكذا انا فهمت ما تريده انت

انصحك باستعمال هذا الملف الذي وضعته للمدرسة عندي Works_Days.xlsm

أسف تم تحميل الملف بدون الماكرو بالخطأ الملف الجديد alex_Wared.xlsm أسف لم انتبه الى ان الملف المرفوع بصيغة xlsx

جرب هذا الكود البيانات كثيرة عندك كان يحب رفع نموذج عن الملف ولبي الملف بكامله (لمعرفة كيفية عمل الكود بشكل مريح) Option Explicit Sub give_uniques() Dim m%: m = 6 Dim Ro_wared%, Ro_Mons% Dim wared As Worksheet: Set wared = Sheets("وارد") Dim Mons As Worksheet: Set Mons = Sheets("منصرف") Ro_wared = wared.Cells(Rows.Count, 1).End(3).Row Ro_Mons = Mons.Cells(Rows.Count, 1).End(3).Row Dim my_sh As Worksheet: Set my_sh = Sheets("salim") my_sh.Range("a6:f5000").ClearContents my_sh.Range("a6:f5000").Font.ColorIndex = xlAutomatic '================================== my_sh.Cells(m, 1).Resize(Ro_wared - 4, 3).Value = _ wared.Cells(5, 1).Resize(Ro_wared - 4, 3).Value my_sh.Cells(m, 4).Resize(Ro_wared - 4, 1).Value = _ wared.Cells(5, 4).Resize(Ro_wared - 4, 1).Value my_sh.Cells(m, 6).Resize(Ro_wared - 4, 1).Value = _ wared.Cells(5, 5).Resize(Ro_wared - 4, 1).Value my_sh.Cells(m, 1).Resize(Ro_wared - 4, 6).Font.ColorIndex = 3 m = Ro_wared + 3 '====================================== my_sh.Cells(m, 1).Resize(Ro_Mons - 4, 3).Value = _ Mons.Cells(5, 1).Resize(Ro_Mons - 4, 3).Value my_sh.Cells(m, 5).Resize(Ro_wared - 4, 1).Value = _ Mons.Cells(5, 4).Resize(Ro_Mons - 4, 1).Value my_sh.Cells(m, 6).Resize(Ro_Mons - 4, 1).Value = _ Mons.Cells(5, 5).Resize(Ro_Mons - 4, 1).Value End Sub الملف مرفق alex_Wared.xlsx

بعد اذن اخي مصطفى لا ضرورة لنبحث في العامود صفاً بعد صف عن رقم معين من خلال استعمال الحلقات التكرارية المرهقة للبرنامح (خاصة اذا كان هناك المئات او الالوف من الصفوف) يوجد طريقة اخرى من خلال الدالة المميزة Find التي تنبش المعلومة اينما كانت (وتضع بدها على الجرح مباشرة ---كما يقول المثل) وتملك خاصية ( النبش) مئات المرات دون كلل او ملل الكود Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$G$3" And Target.Count = 1 Then Get_Data End If Application.EnableEvents = True End Sub '+++++++++++++++++++++++++++++++++++++++++++++++++++++++ Sub Get_Data() Dim ws As Worksheet: Set ws = Sheets("البيانات") Dim sh As Worksheet: Set sh = Sheets("البحث") sh.Range("a6").CurrentRegion.Offset(2).ClearContents Dim My_Number: My_Number = sh.Range("g3") Dim But_Rg As Range: Set But_Rg = ws.Range("a2").CurrentRegion.Columns(2) Dim ro%, fixed_ro% Dim m%: m = 7 Dim Search_Rg As Range Set Search_Rg = But_Rg.Find(My_Number) If Not Search_Rg Is Nothing Then ro = Search_Rg.Row: fixed_ro = ro Do sh.Cells(m, 1).Resize(, 10).Value = ws.Cells(ro, 1).Resize(, 10).Value m = m + 1 Set Search_Rg = But_Rg.FindNext(Search_Rg) ro = Search_Rg.Row If ro = fixed_ro Then Exit Do Loop Else MsgBox "No Data" End If End Sub Search_by Find.xlsm

تم معالجة الامر بالتعديل على الكود Option Explicit Private Sub ComboBox1_Change() fill_val_list If Sheets("Drop List").Range("b10") = vbNullString Then Exit Sub End If End Sub '=============================================== Sub fill_val_list() Dim my_rg As Range Dim i% Dim st$: st = Sheets("Drop List").[b8] Dim arr Application.EnableEvents = False Sheets("Drop List").Range("b10").Validation.Delete On Error GoTo No_Items Set my_rg = ActiveWorkbook.Names(st).RefersToRange ReDim arr(1 To my_rg.Cells.Count) With Sheets("Drop List").Range("b10").Validation For i = 1 To my_rg.Cells.Count arr(i) = my_rg.Cells(i) Next .Add 3, , , Join(arr, ",") End With Sheets("Drop List").Range("b10") = arr(1) Application.EnableEvents = True Exit Sub No_Items: Sheets("Drop List").Range("b10") = vbNullString Sheets("Drop List").Range("b8") = vbNullString Sheets("Drop List").Range("b10").Validation.Delete Application.EnableEvents = True End Sub '====================================== Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$B$10" And Target.Value = vbNullString Then MsgBox "Wrong range", 64 End If Application.EnableEvents = True End Sub الملف الجديد ComboBox With Drop List_new.xlsm

جرب هذا الملف الكود Option Explicit Private Sub ComboBox1_Change() fill_val_list End Sub '=============================================== Sub fill_val_list() Dim my_rg As Range Dim i% Dim st$: st = Sheets("Drop List").[b8] Dim arr Sheets("Drop List").Range("b10").Validation.Delete On Error GoTo No_Items Set my_rg = ActiveWorkbook.Names(st).RefersToRange ReDim arr(1 To my_rg.Cells.Count) With Sheets("Drop List").Range("b10").Validation For i = 1 To my_rg.Cells.Count arr(i) = my_rg.Cells(i) Next .Add 3, , , Join(arr, ",") End With Exit Sub No_Items: MsgBox "Wrong range", 64 End Sub '========== ComboBox With Drop List.xlsm

بعد اذن اخي مصطفى حل اخر بواسطة الكود Option Explicit Sub get_missing_date() Dim my_min#, my_max# Dim cel As Range Dim Col As Object Dim i#, m%: m = 2 Range("G2:G" & Rows.Count).ClearContents Set Col = CreateObject("System.Collections.Arraylist") With Col For Each cel In Range("B2", Range("b1").End(4)) cel.Value = CDate(cel.Value) cel.NumberFormat = "d/m/yyyy" .Add CLng(cel.Value) Next: .Sort End With my_min = Application.Min(Range("B2", Range("b1").End(4))) my_max = Application.Max(Range("B2", Range("b1").End(4))) For i = my_min + 1 To my_max - 1 If (IsError(Application.Match(i, Col.toarray, 0))) _ Then Cells(m, "g") = i: m = m + 1 Next Col.Clear: Set Col = Nothing End Sub الملف مرفق Missing Dates.xlsm

المطلوب Talween.xlsx

ربما كان المطلوب BASMA.xls

جرب هذا الملف DAYS_CALCULATION.xlsx

استعمل هذا الماكرو Option Explicit Sub mohmmedsami() Dim rg As Range Dim y Set rg = Sheets("ورقة1").Range("g1").CurrentRegion.Columns(1) y = rg.Cells.Count - Application.CountBlank(rg) Range("g1:i" & y).Select 'Or Copy End Sub

تم التعديل كما تريد Option Explicit Sub get_data() Application.ScreenUpdating = False Dim dic As Object Set dic = CreateObject("scripting.dictionary") Dim dic_key Dim ro# Dim i%: i = 2 Dim x_titel#: x_titel = 2 Dim find_ro# Dim lrDem# lrDem = Demandes.Cells(Rows.Count, 1).End(3).Row Dim my_rg As Range Set my_rg = Demandes.Range("A1:F" & lrDem) On Error Resume Next Demandes.ShowAllData On Error GoTo 0 Facteur.Range("H:M").Clear lrDem = Demandes.Cells(Rows.Count, 1).End(3).Row Facteur.Range("Q1") = "رقم الفاتورة" With dic Do Until Demandes.Cells(i, 1) = vbNullString If Not .exists(Demandes.Cells(i, 1).Value) Then .Add Demandes.Cells(i, 1).Value, "" End If i = i + 1 Loop For Each dic_key In dic.keys Facteur.Range("H" & x_titel).Resize(8, 2) = _ Range("Header_Rg").Value Range("H" & x_titel + 2).NumberFormat = "0" Facteur.Range("Q2") = dic_key my_rg.AdvancedFilter 1, Facteur.Range("Q1:Q2") Demandes.Range("c1:f" & lrDem). _ SpecialCells(xlCellTypeVisible).Copy _ Facteur.Range("H" & x_titel + 9) Application.CutCopyMode = False Demandes.ShowAllData find_ro = Demandes.Range("A1:A" & lrDem).Find(dic_key).Row With Range("H" & x_titel + 6) .Value = Demandes.Cells(find_ro, 2) .NumberFormat = "d/m/YYY" .Offset(-2, 1) = dic_key End With ro = Facteur.Cells(Rows.Count, "H").End(3).Row Range("K" & ro + 2) = _ Evaluate("SUM(K" & x_titel + 10 & ":K" & ro & ")") Range("H" & ro + 2).Resize(3) = _ Range("RESULT").Value Range("K" & ro + 3) = _ Range("K" & ro + 2) * [D2] / 100 Range("K" & ro + 4) = _ Range("K" & ro + 2) + Range("K" & ro + 3) x_titel = ro + 8 Next dic_key .RemoveAll End With Set my_rg = Nothing Range("Q1:Q2").Clear Columns("H:M").InsertIndent 1 Application.ScreenUpdating = True End Sub '========================= Sub clear_data() Facteur.Range("H:K").Clear End Sub '========================= Sub Print_areas() Application.ScreenUpdating = False Dim My_Area As Range Dim last_row# Dim Serach_RG As Range Dim find_what$: find_what = "الإجمالي شامل الضريبة" Dim My_row#, Fix_row# Facteur.ResetAllPageBreaks last_row = Facteur.Cells(Rows.Count, "H").End(3).Row If last_row = 1 Then GoTo Leave_Me_Alone Set My_Area = Range("H1:K" & last_row) Facteur.PageSetup.PrintArea = My_Area.Address Set Serach_RG = My_Area.Find(find_what, after:=Range("h2")) If Not Serach_RG Is Nothing Then My_row = Serach_RG.Row: Fix_row = My_row Do Facteur.HPageBreaks.Add Before:=Range("H" & My_row + 3) Set Serach_RG = My_Area.FindNext(Serach_RG) My_row = Serach_RG.Row If My_row = Fix_row Then Exit Do Loop End If Leave_Me_Alone: Application.ScreenUpdating = True End Sub '''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Worksheet_Activate() ' Dim t%, h%, w%, l% ' h = 40: w = 140: l = 758 ' With Me.Shapes.Range(Array("Button 1")) ' .Height = h: .Width = w ' .Left = l: .Top = 10 ' End With ' With Me.Shapes.Range(Array("Button 2")) ' .Height = h: .Width = w ' .Left = l: .Top = 60 ' End With ' With Me.Shapes.Range(Array("Button 3")) ' .Height = h: .Width = w ' .Left = l: .Top = 110 ' End With ' End Sub ' '''''''''''''''''''''''''''''''''''''''''''''''' الملف مرفق Tasmim Fatura_with Printing_Special.xlsm

بكل بساطة Sub select_My_range() Range("A11:A100").Select End Sub

تم تحسين العمل كي تتم طباعة كل فاتورة على ورقة منفردة (حسب الاختيار بالضغط على زر تجهيز للطباعة في المرفق) Option Explicit Sub get_data() Application.ScreenUpdating = False Dim dic As Object Dim dic_key Dim ro# Dim i%: i = 2 Dim x_titel#: x_titel = 2 Dim lrDem# Facteur.Range("H:M").Clear lrDem = Demandes.Cells(Rows.Count, 1).End(3).Row Facteur.Range("Q1") = "رقم الفاتورة" Dim my_rg As Range Set my_rg = Demandes.Range("a1:f" & lrDem) Set dic = CreateObject("scripting.dictionary") With dic Do Until Demandes.Cells(i, 1) = vbNullString If Not .exists(Demandes.Cells(i, 1).Value) Then .Add Demandes.Cells(i, 1).Value, "" End If i = i + 1 Loop For Each dic_key In dic.keys Facteur.Range("H" & x_titel).Resize(8, 2).Value = Range("Header_Rg").Value Range("H" & x_titel + 2).NumberFormat = "0" Facteur.Range("Q2") = dic_key my_rg.AdvancedFilter 2, Facteur.Range("Q1:Q2"), Facteur.Range("H" & x_titel + 9) Range("I" & x_titel + 5) = Range("i" & x_titel + 10) Range("I" & x_titel + 5).NumberFormat = "d/m/YYY" Range("I" & x_titel + 4) = dic_key ro = Facteur.Cells(Rows.Count, "H").End(3).Row Range("M" & ro + 2) = Evaluate("SUM(M" & x_titel + 10 & ":M" & ro & ")") Range("M" & ro + 3).Value = Range("M" & ro + 2) * [D2] / 100 Range("M" & ro + 4).Value = Range("M" & ro + 2) + Range("M" & ro + 3) Range("H" & ro + 2).Resize(3).Value = Range("RESULT").Value x_titel = ro + 8 Next End With dic.RemoveAll: Set my_rg = Nothing Range("Q1:Q2").Clear Columns("H:M").InsertIndent 1 Application.ScreenUpdating = True End Sub '========================= Sub clear_data() Facteur.Range("H:M").Clear End Sub '========================= Sub Print_areas() Application.ScreenUpdating = False Dim My_Area As Range Dim last_row# Dim Serach_RG As Range Dim find_what$: find_what = "الإجمالي شامل الضريبة" Dim My_row#, Fix_row# Facteur.ResetAllPageBreaks last_row = Facteur.Cells(Rows.Count, "H").End(3).Row If last_row = 1 Then GoTo Leave_Me_Alone Set My_Area = Range("H1:M" & last_row) Facteur.PageSetup.PrintArea = My_Area.Address Set Serach_RG = My_Area.Find(find_what, after:=Range("h2")) If Not Serach_RG Is Nothing Then My_row = Serach_RG.Row: Fix_row = My_row Do Facteur.HPageBreaks.Add Before:=Range("H" & My_row + 3) Set Serach_RG = My_Area.FindNext(Serach_RG) My_row = Serach_RG.Row If My_row = Fix_row Then Exit Do Loop End If Leave_Me_Alone: Application.ScreenUpdating = True End Sub الملف الجديد مرفق Tasmim Fatura_with Printing.xlsm

جرب هذا الملف الصفجة Facteur الكود Option Explicit Sub get_data() Dim dic As Object Dim dic_key Dim ro# Dim i%: i = 2 Dim x_titel#: x_titel = 2 Dim lrDem# Facteur.Range("H:M").Clear lrDem = Demandes.Cells(Rows.Count, 1).End(3).Row Facteur.Range("Q1") = "رقم الفاتورة" Dim my_rg As Range Set my_rg = Demandes.Range("a1:f" & lrDem) Set dic = CreateObject("scripting.dictionary") With dic Do Until Demandes.Cells(i, 1) = vbNullString If Not .exists(Demandes.Cells(i, 1).Value) Then .Add Demandes.Cells(i, 1).Value, "" End If i = i + 1 Loop For Each dic_key In dic.keys Facteur.Range("H" & x_titel).Resize(8, 2).Value = Range("Header_Rg").Value Range("H" & x_titel + 2).NumberFormat = "0" Facteur.Range("Q2") = dic_key my_rg.AdvancedFilter 2, Facteur.Range("Q1:Q2"), Facteur.Range("H" & x_titel + 9) Range("I" & x_titel + 5) = Range("i" & x_titel + 10) Range("I" & x_titel + 5).NumberFormat = "d/m/YYY" Range("I" & x_titel + 4) = dic_key ro = Facteur.Cells(Rows.Count, "H").End(3).Row Range("M" & ro + 2) = Evaluate("SUM(M" & x_titel + 10 & ":M" & ro & ")") Range("M" & ro + 3).Value = Range("M" & ro + 2) * [D2] / 100 Range("M" & ro + 4).Value = Range("M" & ro + 2) + Range("M" & ro + 3) Range("H" & ro + 2).Resize(3).Value = Range("RESULT").Value x_titel = ro + 8 Next End With dic.RemoveAll: Set my_rg = Nothing Range("Q1:Q2").Clear End Sub '========================= Sub clear_data() Facteur.Range("H:M").Clear End Sub '========================= Tasmim Fatura.xlsm

الصورة لا تنفع اذ لايمكن التعامل مع صورة ولا تنتظر ان يقوم احد من الاساتذة بوضع ملف لك بهذا الحجم حمل قسم من الملف حوالي 20 صف لا أكثر( لوضع الكود المناسب ثم يمكن تعميمه على كامل الملف )مهما كان حجم البيانات

رائع استاذ مصطفى أعتذر لم ارَ ردك على الموضع الا بعد نتزيل ردي انا لكن اقترح ادراح قوائم منسدلة بالاسماء والاكواد دون تكرار (لتفادي خطأ الكتابة مسافة زائدة او غلط املائي الخ....) و توفيراً للوقت

تم معالجة الأمر في هذا الملف 1-بعد اختيار (العنوان الذي تريد ) من الكومبو الاول 2- اختر من الثاتي المعيار الذي تريد 3-اضغط الزر Salim_COMBO.xlsm