محمد هشام.

للاسف الملف لا يشتغل عندي على الجهاز زيادة الموضوع يبدو لي انه اخد اتجاه اخر لا علاقة له باول طلب قمت بارفاقه اخي سعد في انتظار احد الاساتدة يفهم طلبك ويستطيع مساعدتك بالتوفيق ..

يا اخي بدل متكتب على الصور الافضل وضع النتيجة المتوقعة على الملف يدوي ..انت فقط دكرت ان المعادلة تكون في الخلايا الزرقاء بدون دكر مكان وجود نتيجة الطالب لا يعقل اننا نخمن ما تريده بدون معطيات واضحة

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

ناجح v2.xlsx

تقصد بشرط عدد السنوات ..يمكنك تغيير المعادلة بهدا الشكل =INDEX($I$3:$M$6; MATCH(C2;$H$3:$H$6;0); MATCH(B2; $I$2:$M$2; 0)) ملف v3.xlsx

=IF($D$6="";"";IF($D$6="غ";"غ";IF($D$6>=50;"ناجح";IF($D$6<50;"له برنامج علاجي";"")))) ناجح v2.xlsx

انا اشتغت على هدا الاساس انه عند كل ترحيل نحصل على ورقة مستقلة تتضمن راس الصفحة من الاعلى والجزء الاصفر من تحت صراحة اخي سعد لسة مش مستوعب الفكرة... .....

تفضل اخي سعد حاولت قدر الامكان تنفيد المطلوب لاكن بطريقة مختلفة اتمنى ان تستفيد منها مع بعض الاظافات البسيطة في انتظار الرد بعد التجربة sella v4.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته ادا كنت قد فهمت طلبك بشكل صحيح =INDEX($I$3:$I$6;MATCH(C2;$H$3:$H$6);1) v2 ملف.xlsx

تمام ابشر اخي سعد ساحاول تنفيد المطلوب ان شاء الله

سبب التاخير هو المعطيات الغير كافية . المفروض ان لا تجعلنا نخمن ما هو المطلوب وما هي طريقة اشتغالك على الملف استاد سعد بعد المعاينة هناك غموض نوعا ما بما انك تريد جعل الاوراق تحت بعض لمادا انت مثبت نطاق الطباعة هل كل ترحيل هيكون في ورقة مستقلة بداتها تتضمن راس العمود وزيله ام عند ترحيل بيانات جديدة تكون تحت السابقة وهل راس الجدول به قوائم منسدلة ام لا.... المرجوا تزويدنا بالملف الاصلي للاشتغال عليه .

تفضل اخي بالتوفيق..... دوائر v3.xls

تفضل اخي Option Explicit Sub selectasheet() If Not SheetExists("" & Sheets("basic").Range("b2").Value) Then MsgBox "ورقة العمل غير موجودة!" Else Sheets("" & Sheets("basic").Range("b2").Value).Select End If End Sub Function SheetExists(SheetName As String) As Boolean SheetExists = False On Error GoTo NoSuchSheet If Len(Sheets(SheetName).Name) > 0 Then SheetExists = True Exit Function End If NoSuchSheet: End Function المساعدة.xlsm

تفضل اخي Function circle1(dr As Range) Dim OvName As String OvName = "oval" + dr.AddressLocal MrH = 0.3 * dr.Height MrW = 0.2 * dr.Width OvalW = dr.Width - MrW OvalH = dr.Height - MrH Set shShape = dr.Worksheet.Shapes.AddShape(msoShapeOval, dr.Left + MrW / 2, dr.Top + MrH / 2, OvalW, OvalH) With shShape .Name = OvName .Fill.Visible = msoTrue .Line.Weight = False .Fill.ForeColor.RGB = RGB(255, 255, 0) End With End Function دوائر v2.xls

تفضل جرب دوائر.xls

اخي هده مسالة اخرى ليس لها علاقة بالقوائم ولم نشتغل عليها من قبل على العموم تفضل اخي Dynamic Orders - Pivot_V11.xlsm

اخي اولا هل النطاق المرحل ثابث يعني 15 صف ثانيا هل تقصد عند كل ترحيل ان تكون البيانات المرحلة دائما في مابين راس الصفحة وزيلها ثالثا هل الاوراق ستكون تحت بعضها

اخي المفروض وضع الملفات بدون حماية محرر الاكواد او على الاقل ارفاق الباسوورد داخل المشاركة تفاديا لاهدار الوقت على العمود تم كسرها واتمام المطلوب تفضل جرب Dynamic Orders - Pivot_V10.xlsm Dynamic Orders - Pivot_V10.xlsm

=MID(SUBSTITUTE(A$1;" ";"");ROWS(A$2:A2);1)

تفضل اخي In French =SI((LIGNE()-1)<=NBCAR(SUBSTITUE(A$1;" ";""));STXT(SUBSTITUE(A$1;" ";"");LIGNE()-1;1);"") In English =IF((ROW()-1)<=LEN(SUBSTITUTE(A$1;" ";""));MID(SUBSTITUTE(A$1;" ";"");ROW()-1;1);"") فرز.xlsx

مجرد سؤال لمادا تصر على الاشتغال بتعبئة القوائم بالاكواد رغم انها تعطيك رسائل خطا......هناك طرق افضل واسهل يمكنك مثلا انشاء قاعدة بيانات بالاسماء التي تشتغل عليها وربطها بقوائم دينامكية بدون اكواد

العفو اخي قد تم تعديل الملف في المشاركة السابقة يمكنك تحميله من جديد

آسف أخي غير A4 الى C4 If WS_data.Range("A4") = Empty Then: MsgBox "ليس هناك بيانات", 64: Exit Sub With WS_dest

تفضل اخي بالنسبة للترحيل اليك الكود التالي Sub Transfer() Dim K%, DL2%, S%, Rng As Range Dim WS_data As Worksheet: Set WS_data = ThisWorkbook.Sheets("تسجيل البيعة") Dim WS_dest As Worksheet: Set WS_dest = ThisWorkbook.Sheets("تسجيل المخزون") Application.ScreenUpdating = False K = WS_data.Range("C65500").End(xlUp).Row + 1 If WS_data.Range("C4") = Empty Then: MsgBox "ليس هناك بيانات", 64: Exit Sub If WS_data.Range("D2") = Empty Then: MsgBox "المرجوا ادخال التاريخ", 64: Exit Sub If WS_data.Range("H2") = Empty Then: MsgBox "المرجوا ادخال رقم الفاتورة", 64: Exit Sub With WS_dest DL2 = WS_dest.Range("C65500").End(xlUp).Row + 1 S = DL2 + K - 4 WS_dest.Range("F" & DL2 & ":F" & S) = WS_data.Range("c4:c" & K).Value WS_dest.Range("G" & DL2 & ":G" & S) = WS_data.Range("D4:D" & K).Value WS_dest.Range("H" & DL2 & ":H" & S) = WS_data.Range("E4:E" & K).Value WS_dest.Range("I" & DL2 & ":I" & S) = WS_data.Range("F4:F" & K).Value WS_dest.Range("C" & DL2 & ":C" & S) = WS_data.Range("D2") WS_dest.Range("D" & DL2 & ":D" & S) = WS_data.Range("H2") WS_dest.Range("E" & DL2 & ":E" & S) = WS_data.Range("J2") End With Set Rng = WS_data.Range("C4:I" & K).SpecialCells(xlCellTypeConstants) Rng.ClearContents Application.ScreenUpdating = True End Sub اما بالنسبة لتصفية البيانات يمكنك استخدام هدا الكود Sub BFVB() Dim lastRow As Long, lrow As Long, Article As Range Dim sh As Worksheet: Set sh = ThisWorkbook.Sheets("الشهر") lrow = sh.Range("A" & Rows.Count).End(xlUp).Row + 1 Set Rng = sh.Range("C2") Dim sh2 As Worksheet: Set sh2 = ThisWorkbook.Sheets("تسجيل المخزون") lastRow = sh2.Range("C" & Rows.Count).End(xlUp).Row If Rng.Value = Empty Then MsgBox "المرجو ادخال الصنف": Exit Sub On Error Resume Next Set Article = sh2.Range("G:G").Find(What:=Rng, LookIn:=xlValues, LookAt:=xlWhole) If Not Article Is Nothing Then Application.ScreenUpdating = False sh.Range("A4:G" & lrow).ClearContents sh2.Range("G1").AutoFilter Field:=5, Criteria1:="=" & Rng sh2.Range("C1").AutoFilter Field:=1, _ Criteria1:=">=" & sh.Range("E1").Value2, Operator:=xlAnd, _ Criteria2:="<=" & sh.Range("E2").Value2 With sh2 sh2.Range("C2:I" & lastRow).SpecialCells(xlCellTypeVisible).Copy sh.Range("A4").PasteSpecial xlPasteValues sh.Activate DL = sh.Range("A65500").End(xlUp).Row DC = sh.Cells(3, Columns.Count).End(xlToLeft).Column sh.Range("A3:G100").Borders.LineStyle = xlNone sh.Range(Cells(3, 1), Cells(DL, DC)).Borders.Weight = xlThin On Error GoTo 0 End With Else m = MsgBox("الصنف " & " " & Rng & " " & " " & "غير موجود", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "") End If On Error Resume Next sh2.ShowAllData Application.ScreenUpdating = True On Error GoTo 0 End Sub مع وضع هدا الكود في حدث شيت (الشهر) Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub If Target.Address(False, False) = "C2" And Target.Value <> "" Then Call BFVB End If End Sub mywork 6.xlsm

تفضل اخي تم الاعتماد على رقم التسلسل لتعديل البيانات او حدفها بحكم انه هو الوحيد الغير مكرر عندك على الجدول Sub Délete_Client() ' حدف Dim WS As Worksheet, WS2 As Worksheet Dim i As Long, ST As Long Dim msg As VbMsgBoxResult, Client As String Set WS = Worksheets("Orders") Set WS2 = Worksheets("Items") Client = WS2.Range("F4") N_row = WS2.Range("W1") Application.ScreenUpdating = False If Client = Empty Then MsgBox Client & "المرجوا تحديد الصف المراد حدف بياناته", vbExclamation, "إنتباه" Exit Sub End If msg = MsgBox(" هل انت متأكد من حدف : " & Client, vbYesNo + vbQuestion + vbDefaultButton2, "إنتباه") Application.ScreenUpdating = False If msg = vbNo Then Exit Sub End If WS.Activate For i = Cells(Rows.Count, 2).End(xlUp).Row To 7 Step -1 If Cells(i, 2).Value = N_row Then Rows(i).Delete End If Next i For ST = 7 To Cells(Rows.Count, "B").End(xlUp).Row If Cells(ST, "c").Value <> "" Then Cells(ST, "b").Value = ST - 6 End If Next ST WS2.Activate WS2.Range("H15,F4,F6,H6,F9,H9,J9,F13,H13,J13,F15,J15,F18,H18,F20,J21,w1") = Empty Application.ScreenUpdating = True m = MsgBox("تم حدف البيانات بنجاح", 64, "تأكيد") End Sub Dynamic Orders - Pivot_V6.xlsm