سليم حاصبيا

جرب هذا المرفق تم اضافة رقمين الى الجدول حتى يصبح 14 رقم موزعة على رقمين كل يوم الكود Option Explicit Sub Rand() Dim g(14), c, r, arr(), t$ ReDim arr(1 To 2) Do c = Application.RandBetween(1, 14) If Not g(c) Then r = r + 1 arr(r) = c t = "=INDEX($F$4:$F$17," & arr(r) & ")" Cells(r + 1, "a") = Evaluate(t) g(c) = True End If Loop Until r = 2 End Sub الملف Random_salim.rar

جرب هذه الملف في النطاق A2:k11 (يمكن تعديل هذا النطاق من داخل الكود) الكود مرفق Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim my_rg As Range Dim col%, r%, x%, t% Application.EnableEvents = False Set my_rg = Range("a2:k11") If Intersect(Target, my_rg) Is Nothing Then GoTo 1 If Target.Rows.Count <> 1 Then GoTo 1 r = Target.Row: col = Target.Column t = Cells(r, 1).End(xlToRight).Column: If t > 11 Then t = 1 x = Application.CountA(Range(Cells(r, 1), Cells(r, col))) If x <> col Then MsgBox ("Out Of range") Target.Value = vbNullString If t = 1 Then Cells(r, 1).Select Else Cells(r, t + 1).Select End If End If 1: Application.EnableEvents = True End Sub الملف No_cells_to_skeep.rar

ارفع الملف نفسه او نسخة(فارغة ) عنه اذ لا يمكن التعامل مع الصورة

بعد اذن اخي ياسر جرب هذا الملف هناك 2 كود الاول في حدث الصفحة invoice Option Explicit Private Sub Worksheet_Activate() Dim answer% answer = MsgBox("هل تريد زيادة ترقيم الفاتورة", vbYesNo + vbMsgBoxRight + vbMsgBoxRtlReading + vbQuestion, "ُExcel Ask You") If answer = 6 Then Me.Range("d5") = Me.Range("d5") + 1 Me.Rows.Hidden = False End If End Sub الثاني في Mudule عادي Salim Option Explicit Sub Copy_Data() Dim Sh_To_Copy As Worksheet, Sh_To_Paste As Worksheet Dim Rg_Copy As Range Dim lrCopy%, Lrpast%, m%, My_Num%, i% Dim My_Str As String, Answer2% Set Sh_To_Copy = Sheets("invoice"): Set Sh_To_Paste = Sheets("recycle") Sh_To_Paste.Unprotect 11 Sh_To_Copy.Range("a9:f25").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True My_Str = Sh_To_Copy.Range("c5").Value My_Num = Sh_To_Copy.Range("d5").Value lrCopy = Sh_To_Copy.Cells(Rows.Count, 1).End(3).Row Lrpast = Sh_To_Paste.Cells(Rows.Count, 1).End(3).Row For i = 5 To Lrpast If Sh_To_Paste.Range("c" & i) = My_Str And Sh_To_Paste.Range("d" & i) = My_Num Then Answer2 = MsgBox("الفاتورة تحت هذا الرقم موجوده هل تريد استبدالها", vbYesNo) If Answer2 <> 6 Then Sh_To_Paste.Protect 11: Exit Sub Exit For End If Next Set Rg_Copy = Sh_To_Copy.Range("a5:F" & lrCopy).SpecialCells(12) m = Rg_Copy.Rows.Count Sh_To_Paste.Range("a5:a" & m + 8).EntireRow.Insert Rg_Copy.Copy Sh_To_Paste.Range("a5") Sh_To_Paste.Protect 11 End Sub Facture_salim.rar

اوضح ماذا تريد بلغة الاكسل 1-هل تريد ان يكون لكل اسم صفحة خاصة به؟ام ان الصغحة الواحدة يمكن ان تحتوي على عدة حسابات 2- يرجى عدم ترك اعمدة فارغة لان اكسل في هذه الحالة لا يعتير اليبانات كجدول واحد و بذلك تتعقد الامور على الكود 3- ادراج بعض البيانات و النتائج المتوقعة

بعد اذن اخي ابو البراء بالمعادلات: في B2 ,اسحب نزولاً =LEFT(TRIM(A2),FIND("(",TRIM(A2))-1) في D2 اسحب نزولاً =SUBSTITUTE(MID(TRIM(A2),(FIND("*",TRIM(A2))),((FIND("سعر",TRIM(A2)))-(FIND("*",TRIM(A2)))-1)),"*","")+0

يا أخي: لماذا لا تريد ان تصدق ان الكود يقوم ينسخ الخلايا المرئية فقط من الشيت recycle ,وينقلها الى الشيت invoice وذ لك بفضل ما هو باللون الاحمر في هذه 3 أسطر من الكود Worksheets("recycle").Range("a" & arr(x) & ":f" & arr2(x)).SpecialCells(xlCellTypeVisible).Copy Sheets("invoice").Range("a" & last_row).PasteSpecial Paste:=xlPasteValues Sheets("invoice").Range("a" & last_row).PasteSpecial Paste:=xlPasteFormats الصفحة الاساسية :recycle الصفحة المنقول اليها:invoice استبدل الكود بهذا كي لا تظهر( الساعة الرملية) اذا لم يكن في احد الفواتير "فاتورة مبيعات رقم" او "الاجمالي" فإن الكود يمسح البيانات من ورقة invoice و يتوقف عن العمل Option Explicit Sub Test_Me() Dim rngFind As Range Dim strFindMe$ Dim r%, r1%, x%, last_row%, k%, rr% Dim arr(), arr2() k = 1 last_row = 1 With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With On Error Resume Next Sheets("invoice").Cells.Clear strFindMe = "فاتورة مبيعات رقم" With Worksheets("recycle").Range("c:c") Set rngFind = .Find(what:=strFindMe, LookIn:=xlValues) If Not rngFind Is Nothing Then r = rngFind.Row ReDim Preserve arr(1 To k) arr(k) = r Do Until r = r1 Set rngFind = .FindNext(rngFind) r1 = rngFind.Row k = k + 1 ReDim Preserve arr(1 To k) arr(k) = r1 Loop End If ReDim Preserve arr(1 To k - 1) End With If r = 0 Then GoTo 1 '============================================ k = 1 r1 = 0: r = 0 strFindMe = "الاجمالي" With Worksheets("recycle").Range("a:f") Set rngFind = .Find(what:=strFindMe, LookIn:=xlValues) If Not rngFind Is Nothing Then rr = rngFind.Row ReDim Preserve arr2(1 To k) arr2(k) = rr Do Until r1 = rr Set rngFind = .FindNext(rngFind) r1 = rngFind.Row k = k + 1 ReDim Preserve arr2(1 To k) arr2(k) = r1 Loop End If ReDim Preserve arr2(1 To k - 1) End With If rr = 0 Then GoTo 1 If UBound(arr) <> UBound(arr2) Then GoTo 1 '============================================ For x = UBound(arr) To LBound(arr) Step -1 Worksheets("recycle").Range("a" & arr(x) & ":f" & arr2(x)).SpecialCells(xlCellTypeVisible).Copy Sheets("invoice").Range("a" & last_row).PasteSpecial Paste:=xlPasteValues Sheets("invoice").Range("a" & last_row).PasteSpecial Paste:=xlPasteFormats last_row = Sheets("invoice").Cells(Rows.Count, 1).End(3).Row + 2 Next 1: Erase arr: Erase arr2: Set rngFind = Nothing: strFindMe$ = vbNullString With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .CutCopyMode = False End With End Sub الملف مرفق Copy_Invoices Corriger.rar

بعد اذن اخي ابو البراء هذا الكود(لا تدرج المعادلة اذا كانت الخلية فارغة) Option Explicit Sub create_formula() Dim my_rg As Range Dim Row%, i% Set my_rg = Range("d7").CurrentRegion Row = my_rg.Rows.Count + 6 my_rg.Offset(1, 0).Columns(3).ClearContents For i = 8 To Row If Not IsEmpty(Cells(i, 5)) Then Cells(i, 6).Formula = "=IF(OR(COUNTIF($I$8:$I$100," & Cells(i, 5) & ")=0," _ & Cells(i, 5) & "=""""),"""",VLOOKUP(" & Cells(i, 5) & ",$I$8:$J$100,2,0))" End If Next End Sub

جرب هذه المعادلة في F8 واسحب نزولاُ =IF(OR(COUNTIF($I$8:$I$100,$E8)=0,$E8=""),"",VLOOKUP($E8,$I$8:$J$100,2))

لا أعلم ما السبب عندك مع انه عندي يعمل بسرعة كيرة

جرب هذا الكود عذراً بم اسنطع نحميل الكود بسبب بطء النت الملف مرفق Copy_Invoices.rar

جرب هذه المعادلة في الخلية E2 واسحب نزولاً (يحب استعمال Ctrl+Shift+Enter و ليس Enter وحدها لانها معادلة صفيف) Array_Fromula) كما يجب نتسيق الخلايا في العامود E كتاريخ =INDEX(البيانات!$R$2:$AD$1000,MATCH(الخلاصة!A2,البيانات!$H$2:$H$1000,0),(MATCH("Ok",IF(NOT(INDEX(البيانات!$R$2:$AA$1000,MATCH(الخلاصة!$A2,البيانات!$H$2:$H$1000,0),)),"Ok"),0))-1) اذا لم تعمل معك المعادلة استبدل الفاصلة "," بفاصلة منقوطة ";" (حسب اعدادات الجهاز عندك ) لتصبح هكذا =INDEX(البيانات!$R$2:$AD$1000;MATCH(الخلاصة!A2;البيانات!$H$2:$H$1000;0);(MATCH("Ok";IF(NOT(INDEX(البيانات!$R$2:$AA$1000;MATCH(الخلاصة!$A2;البيانات!$H$2:$H$1000;0);));"Ok");0))-1)

الصفوف الفارغه لا يتم ترحيلها الى الصفحة الثانية كي يتم حذفها

أولاً -ما ذكرته في الرد على الاخ ياسر ابو البراءء: "وفي نفس الوقت لا اريد ان احذفها من الفاتورة الاصليه كي املئها مرة اخري بعد ذلك" لماذا تقم بتغيير رأيك ثانياً-لا احد يتشتري سمكاً في البحر ولا يمكن التخمين في هذا الامر ثالثاُ- ارفع ملفاً وهمياً عما تريد (فقط ثلاثة او اربع فواتير اي حوالي 20 سطر لا أريد الملف الاصلي فقط ملف مشابه ولا اريد صورة لانه لا يمكن التعامل مع الصور)

جرب هذا الملف TARTIB.rar

و في حال تساوي رقمين او اكثر ما هي التنيجة

حيث انك لم ترفع اي ملف للمعالجة فقد كونت لك ملفاً يسيطاً كنموذج للتعامل تستطيع ان تعدل الماكرو داخله كما تريد البيانات الاساسية في الورقة1 البيانات المنقولة في الورقة2 copy_visible.rar

لو فرضنا ان الارقام عندك في العامود A ابتداء من A1 اكتب هذه المعادلة في B1 و اسحب نزولاً =IF(ISERR(SIGN(A1)),"",CEILING(A1,0.5))

اسنعمل هذا التنسيق للخلايا [$-2010000]yyyy/mm/dd;@

ربما ينفع هذا الكود Option Explicit Sub del_special_cells() Dim cel As Range With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With For Each cel In Range("a10").CurrentRegion If cel.Interior.ColorIndex = 6 Then _ cel.Value = vbNullString Next With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub

تستطيع ان تعدل في الكود ما تره مناسباً اليك هذا التعديل Option Explicit Sub EXTRACT_DATA() Dim lr%, LR1% Application.ScreenUpdating = False lr = Sheets("Salim").Cells(Rows.Count, 1).End(3).Row Sheets("Result").Cells.Clear Sheets("Salim").Range("A8:k" & lr).Copy Sheets("result").Activate Range("p9").Select Selection.PasteSpecial Paste:=-4163 Selection.PasteSpecial Paste:=-4122 Application.CutCopyMode = False With Sheets("Result") .Columns("t:y").Delete .Rows(10).Delete LR1 = .Cells(Rows.Count, "p").End(3).Row With .Sort .SortFields.Clear .SortFields.Add Key:=Range("s9"), Order:=xlAscending '===================== .SetRange Range("p9:t" & LR1) .Header = xlYes .Apply End With '============================ .Range("p10:p" & LR1).Formula = "=IF(q10="""","""",MAX($p$9:p9)+1)" .Range("p10:p" & LR1).Value = .Range("p10:p" & LR1).Value .Range("p10").Select End With Application.ScreenUpdating = True End Sub اذا كنت تريد ذلك في نفس الصفحة هذا الكود Option Explicit Sub EXTRACT_DATA2() Dim lr%, LR1% Application.ScreenUpdating = False lr = Sheets("Salim").Cells(Rows.Count, 1).End(3).Row Sheets("Salim").Range("p8:t" & lr).Clear Sheets("Salim").Range("A8:k" & lr).Copy Range("p8").Select Selection.PasteSpecial Paste:=-4163 Selection.PasteSpecial Paste:=-4122 Application.CutCopyMode = False With Sheets("Salim") .Columns("t:y").Delete LR1 = .Cells(Rows.Count, "p").End(3).Row With .Sort .SortFields.Clear .SortFields.Add Key:=Range("s8"), Order:=xlAscending '===================== .SetRange Range("p8:t" & LR1) .Header = xlYes .Apply End With '============================ .Range("p9:p" & LR1).Formula = "=IF(q9="""","""",MAX($p$8:p8)+1)" .Range("p9:p" & LR1).Value = .Range("p9:p" & LR1).Value .Range("p9").Select End With Application.ScreenUpdating = True End Sub

يمكن ان يكون المطلوب انظر الى الصفحة Result EXTRACT_DATA.rar

اخي ياسر زيادة في الازعاج و زيادة في اثراء الموضوع نفس الملف لكن بالمعادلات انظر الى الورقة By_formula من فضلك عسى ان ينال الاعجاب Sum By Choosen_rows By_fromula.rar

يظهر ان عدد الخلايا المحددة اكبر من عدد الكومبوبوكس او الليست بوكس او اي نوع من الكونترول لتلافي الرسالة أضف هذه العبارة بعد كل الاسطر Dim On Error Resume Next

بعد إذن اخي الحبيب ياسر ابو البراء جرب هذا الملف حيث يمكنك تحديد عدد الصفوف المطلوبة في كل مجموعة Sum By Choosen_rows.rar