محمد هشام.

المشكلة أخي ليس من اليوزرفورم المشكلة من مكان جلب البيانات حاول مراجعة المعادلة الموجودة في ورقة الادخال عمود CF . وإعادة ظبط نطاق القوائم المنسدلة. المهم تم استبدال عمود جلب البيانات الى عمود CK اي اظافة جديدة أو تعديل قم باظافتها هناك لتظهر معك على الكومبوبوكس مخزون V5.xlsm

تفضل اخي userform.New.xlsm

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

تفضل جرب Sub FILTRE() Dim Rng As Range, lr As Long, b As Range, c As Range Dim sh1 As Worksheet: Set sh1 = ThisWorkbook.Worksheets("Sheet1") Dim sh2 As Worksheet: Set sh2 = ThisWorkbook.Worksheets("Sheet2") Set a = sh2.Range("A1") Set b = sh2.Range("D10:J1000") Set c = sh2.Range("M10:S1000") If a = Empty Then: Exit Sub With Application .ScreenUpdating = False: .EnableEvents = False End With With sh1 Set Rng = .Range("C9:K" & .Cells(.Rows.Count, "D").End(xlUp).Row) End With Union(b, c).ClearContents [G1] = "" [P1] = "" With Rng Dim cntCrit As Long cntCrit = WorksheetFunction.CountIfs(Rng.Columns(6), "ذكر") If cntCrit <> 0 Then .AutoFilter Field:=6, Criteria1:="ذكر" .AutoFilter Field:=9, Criteria1:=a lr = sh2.Range("D" & Rows.Count).End(3).Row + 1 .Offset(1, -1).Resize(.Rows.Count - 1, .Columns.Count).Copy sh2.Cells(10, "B").PasteSpecial Paste:=xlPasteValues countmales = WorksheetFunction.CountIf(sh2.Range("H10:H1000"), "ذكر") sh2.Range("G1") = countmales End If With Rng cntCrit = WorksheetFunction.CountIfs(Rng.Columns(6), "انثي") If cntCrit <> 0 Then .AutoFilter Field:=6, Criteria1:="انثي" .AutoFilter Field:=9, Criteria1:=a lr = sh2.Range("M" & Rows.Count).End(3).Row + 1 .Offset(1, -1).Resize(.Rows.Count - 1, .Columns.Count).Copy sh2.Cells(10, "K").PasteSpecial Paste:=xlPasteValues countfemales = WorksheetFunction.CountIf(sh2.Range("Q10:Q1000"), "انثي") sh2.Range("P1") = countfemales End If .Parent.AutoFilterMode = False End With End With With Application .ScreenUpdating = True: .EnableEvents = True: .CutCopyMode = False End With a.Select End Sub test_saad.xlsm

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

مرحبا استاد ابو احمد ربما لم افهم جيدا السؤال لاكن مجرد توضيح السائل كاتب عندما اكتب رقم السيارة يحضر لى تلقائي اخر عداد حالي للسيارة في يكتب في العداد السابق العداد الحالي موجود في عمود P بالنسبة لهدا الحل اخي ابو احمد لابد له من انشاء ورقة جديدة وادخال اخر عداد يدويا بالجدول في حالة كنت قد استوعبت السؤال فهناك عدة حلول بدون انشاء ورقة اخرى منها =IF(K5=0;"";INDEX(P$5:P$2000;MATCH(K5;1/(K5=K$5:K$2000))))

تفضل ربما هدا ماتقصد =LOOKUP(3;(1/($K$5:$K$5000=K5))+(1/($P$5:$P$5000<>""));$P$5:$P$5000) =IFERROR(IF(K5<>"";LOOKUP(3;(1/($K$5:$K$5000=K5))+(1/($P$5:$P$5000<>""));$P$5:$P$5000);"");"") متابعة السيارات.xlsx

التغيير سيكون في macro1 اجعله هكدا Public gtxtCalTarget As Variant Public Function LogError(lngErr As Long, strDescrip As String, strProc As String, _ Optional bShowUser As Boolean = True, Optional varParam As Variant) If bShowUser Then MsgBox "Error " & lngErr & ": " & strDescrip, vbExclamation, strProc End If End Function Public Function CalendarFor2(txt As Variant) On Error GoTo Err_Handler gtxtCalTarget = TextBox1 GalendarForm.Show Exit_Handler: Exit Function Err_Handler: MsgBox "Error " & Err.Number & " - " & Err.Description, vbExclamation, "CalendarFor()" Resume Exit_Handler End Function وبعد اظافة الصورة مثلا Private Sub Image1_click() Call CalendarFor2(Me.TextBox1) End Sub اليك المرفق بعد اظافة تقويم جديد يمكنك اختيار ما يناسيك يوزر فورم 2 التقويم.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب اخي المرفق التالي يوزر فورم التقويم.xlsm

تفضل اخي تم اصلاح بعض الاخطاء في الاكواد سبب تهنيج الملف هو كود اظهار الساعة على اليوزرفورم قد تم استبداله بطريقة اخرى 1) تم تفعيل اكواد يوزرفورم 3 كما طلبت من قبل بطريقتين مختلفتين يمكنك اختيار ما يناسبك. 2) تم تعديل اكواد يوزرفورم 1 لتتماشى مع طريقة اشتغال الملف 3) تم استبدال معادلة ادراج تاريخ اليوم في عمود A بالكود التالي تفاديا لاظهار رسالة (Circular reference) Private Sub Worksheet_Change(ByVal TaFet As Range) Dim myRng As Range, F As Range, Col As Integer, lr As Long Set myRng = Intersect(Application.ActiveSheet.Range("B3:B2000"), TaFet) 'Column("A") Col = -1 If Not myRng Is Nothing Then For Each F In myRng If Not VBA.IsEmpty(F.Value) Then F.Offset(0, Col).Value = Now F.Offset(0, Col).NumberFormat = "dd-mm-yyyy" Else F.Offset(0, Col).ClearContents End If Next End If End Sub اكواد يوزرفورم 3 Dim F, K, WS_Data(), LigneN_Row Private Sub UserForm_Initialize() Set F = Sheet5 'Worksheets("الدخول") Set K = F.Range("A3:V" & F.[A65000].End(xlUp).Row) WS_Data = K.Value Set Réf = CreateObject("Scripting.Dictionary") a = F.Range("j3:j" & F.[j65000].End(xlUp).Row) For I = LBound(a) To UBound(a) If a(I, 1) <> Empty Then Réf(a(I, 1)) = Empty Next I WS2 = Réf.keys Me.ComboBox1.List = WS2 vidange_Click Me.TextBox1.SetFocus ComboBox1 = "*" Me.N_Row.Visible = False End Sub '''''''''''''''''''''''''''''' Private Sub ListBox1_Click() Me.TextBox1.Value = Me.ListBox1.Column(0) Me.ListBox1.Visible = False For I = 1 To UBound(WS_Data) If WS_Data(I, 10) = Me.TextBox1.Text Then N_linge = I Me.N_Row = N_linge + K.Row - 1 End If Next I Me.TextBox2.Text = WS_Data(N_linge, 10) ''''''''''''''' ' جلب التاريخ والساعة 'Me.TextBox3.Text = WS_Data(N_linge, 1) 'جلب التاريخ فقط Me.TextBox3.Text = Format(CDate(WS_Data(N_linge, 1)), "MM/DD/YYYY") '''''''''''''' Me.TextBox4.Text = WS_Data(N_linge, 6) Me.TextBox5.Text = WS_Data(N_linge, 7) Me.TextBox6.Text = WS_Data(N_linge, 9) Me.TextBox7.Text = WS_Data(N_linge, 2) Me.ComboBox1 = "*" Me.TextBox1 = "" End Sub '''''''''''''''''''''''''''' Private Sub TextBox1_Change() If Me.TextBox1.Text = "" Then Me.ListBox1.Visible = False Else Me.ListBox1.Visible = True Me.ListBox1.Clear '------------------------------ Dim K Set w = Sheet5 K = w.Cells(Rows.Count, 10).End(xlUp).Row l = 0 For Each c In Range("j3:j" & K) If c Like TextBox1.Text & "*" Then ListBox1.AddItem ListBox1.List(l, 0) = Cells(c.Row, 10).Value l = l + 1 End If Next c End If Me.ComboBox1 = "*" End Sub Private Sub vidange_Click() For I = 1 To 7 Controls("textbox" & I).Text = Empty Next I Me.ComboBox1 = "*" End Sub Private Sub TextBox1_DblClick(ByVal cancel As MSForms.ReturnBoolean) If Not iGblInhibitTextBoxEvents Then TextBox1.Value = "" Me.ComboBox1 = "*" End If End Sub ''''''''''''''''''''''''''' Private Sub ComboBox1_click() For I = 1 To UBound(WS_Data) If WS_Data(I, 10) = Me.ComboBox1.Text Then N_linge = I Me.N_Row = N_linge + K.Row - 1 End If Next I Me.TextBox2.Text = WS_Data(N_linge, 10) ''''''''''''''' ' جلب التاريخ والساعة 'Me.TextBox3.Text = WS_Data(N_linge, 1) 'جلب التاريخ فقط Me.TextBox3.Text = Format(CDate(WS_Data(N_linge, 1)), "MM/DD/YYYY") '''''''''''''' Me.TextBox4.Text = WS_Data(N_linge, 6) Me.TextBox5.Text = WS_Data(N_linge, 7) Me.TextBox6.Text = WS_Data(N_linge, 9) Me.TextBox7.Text = WS_Data(N_linge, 2) Me.TextBox1.Text = Empty End Sub في انتظار ان توافينا بالنتيجة بعد التجربة بالتوفيق مخزون V3.xlsm

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

وعليكم السلام ورحمة الله تعالى وبركاته Sub lastname() ' اخر اسم على الجدول Dim ws As Worksheet: Set ws = ActiveSheet Dim myRng As Range Set myRng = ws.Range("C4", Range("c" & Rows.Count).End(4)).SpecialCells(xlCellTypeFormulas, 2) With myRng myRng.Cells(myRng.Rows.Count, 1).Select End With End Sub ''''''''''''''''''''''''''''''''''''''''''''''' Sub lastname2() ' اخر صف في الجدول Columns("C").Find(What:="*", LookIn:=xlValues, SearchDirection:=xlPrevious).Select End Sub كود اول واخر اسم.xlsm

تفضل Sub Copy_My_Data() Dim wsDest As Worksheet Dim LR As Long, LR1 As Long Dim msg As VbMsgBoxResult Dim Rng As Range, wsCopy As Worksheet msg = MsgBox(" ترحيل البيانات الى مصنف أحمد ؟", vbYesNo + vbQuestion + vbDefaultButton2, "تأكيد") If msg = vbYes Then Application.ScreenUpdating = False Set wsCopy = Sheets("Sheet1") With wsCopy LR = .Cells(Rows.Count, 3).End(xlUp).Row Set Rng = .Range(.Cells(10, "C"), .Cells(LR, "L")) End With Set wsDest = Workbooks.Open(ThisWorkbook.Path & "\أحمد.xlsm").Sheets("Sheet9") LR1 = wsDest.Cells(wsDest.Rows.Count, "C").End(xlUp).Row + 1 If wsDest.Range("C10") = Empty Then Rng.Copy wsDest.Range("C10").PasteSpecial Paste:=xlPasteValues Else Rng.Copy wsDest.Range("C" & LR1).PasteSpecial Paste:=xlPasteValues End If Set WS = Workbooks("أحمد.xlsm").Sheets("Sheet1") WCopy = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row WDest = wsDest.Cells(wsDest.Rows.Count, "C").End(xlUp).Offset(1).Row WS.Range("C10:L" & WCopy).Copy wsDest.Range("C" & WDest).PasteSpecial Paste:=xlPasteValues [C10].Select Application.CutCopyMode = False Workbooks("أحمد.xlsm").Close True Application.ScreenUpdating = True End If End Sub Saad2.rar

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

وعليكم السلام ورحمة الله تعالى وبركاته بعد المعاينة يبدوا لي انك بحاجة لتعديل اكواد اليوزرفورم 1 و 2 لانهم لهم نفس المشكلة عدم اظهار البيانات عند الانتقال الى ورقة الادخال تفصل اخي بالنسبة لليوزرفورم 1 قم باظافة الكود التالي Private Sub UserForm_Activate() Set f = Sheets("الدخول") Set d = CreateObject("Scripting.Dictionary") Set WSdata = f.[a3].CurrentRegion.Offset(1) ' العمود ("CF") Search_column = 84 For i = 3 To WSdata.Rows.Count clé = WSdata.Cells(i, Search_column): d(clé) = "" Next i On Error Resume Next Me.Combobox1.List = d.keys On Error GoTo 0 End Sub اما بالنسبة لليوزرفورم 2 قم بحدف جميع الاكواد الموجودة عليه وقم بنسخ الكود التالي Private Sub TextBox1_Change() Dim w As Integer, Last& If Me.TextBox1.Text = Empty Then Me.ListBox1.Visible = False ListBox1.Clear Else Me.ListBox1.Visible = True Last = Sheet2.Cells(Rows.Count, 4).End(xlUp).Row w = 0 For Each c In Sheet2.Range("D2:D" & Last) If c Like Me.TextBox1.Text & "*" Then Me.ListBox1.AddItem Me.ListBox1.List(w, 0) = Sheet2.Cells(c.Row, 4).Value w = w + 1 End If Next c End If End Sub Private Sub CommandButton2_Click() Dim sh1 As Worksheet, f As Range Set sh1 = Sheet2 With Me.cl If .Value = Empty Then Exit Sub End If Set f = sh1.Range("D:D").Find(.Value, , xlValues, xlWhole, , , False) If Not f Is Nothing Then Me.fk.Value = sh1.Range("H" & f.Row).Value Me.fm.Value = sh1.Range("I" & f.Row).Value Me.fq.Value = sh1.Range("J" & f.Row).Value End If End With End Sub Private Sub ListBox1_Click() Me.cl.Text = Me.ListBox1.Column(0) Me.ListBox1.Visible = False Me.TextBox1.Text = "" End Sub Private Sub CommandButton1_Click() Unload Me End Sub مخزون V2.xlsm

لقد تمت الاجابة فعلا على طلبك انت الان تطلب شيء مغاير لا علاقة له بالكود المرفق على ما اظن 2) ممكن توضح سؤالك اكثر عايز ترحل ايه بالظبط وفين

بما انك مبتدا اليك حل اخر ربما يناسبك ميزته انه سيعفيك من تعديل الاكواد واظافة اسماء الشيتات حيث يتم كل شيء تلقائيا دون تدخل منك يكفي فقط اظافة اي قيمة تعجبك امام الشيت المرغوب جلب بياناته (لم اقم بتحديدها لتبقى لك الحرية التامة في الاستخدام ) اليك رابط طريقة الاستخدام للتوضيح نسخ البيانات من عدة اوراق عمل بشرط تحديدها في عمود (streamable.com) الاكواد المستخدمة Sub All_School() Dim wsArr() As String Dim sh&, Y&, c As Range, Rng2 As Range, R As Range Dim a As Long, rng As Long, b As Long, J As Long, LastRow As Long Dim ST1 As Worksheet, Dest As Worksheet Application.ScreenUpdating = False Set Dest = Sheets("All_School") For Each ST1 In Sheets If ST1.Name <> Dest.Name Then Set R = Dest.Range("AA:AA").Find(ST1.Name, , xlValues, xlWhole, , , False) If Not R Is Nothing Then If Dest.Range("AB" & R.Row).Value <> "" Then LastRow = Dest.Cells(Rows.Count, "B").End(xlUp).Row + 1 J = Dest.Range("AA" & Rows.Count).End(xlUp).Row Set Rng2 = Dest.Range("AB2:AB" & J) If Application.WorksheetFunction.CountIf(Dest.Range("AB2:AB" & J), "<>") > 0 Then For Each c In Rng2 If c Then If c <> "" Then ReDim Preserve wsArr(0 To sh) wsArr(sh) = c.Offset(, -1).Value sh = sh + 1 Else Exit Sub End If End If Next Dest.Range("A5:X" & LastRow).ClearContents For K = LBound(wsArr) To UBound(wsArr) With Worksheets(wsArr(K)) .Activate a = Range("A" & Rows.Count).End(xlUp).Row ws = Range("B5:X" & a) End With b = Dest.Range("B" & Rows.Count).End(xlUp).Row With Dest.Cells(b + 1, "B") .Resize(UBound(ws, 1), UBound(ws, 2)) = ws End With Next Dest.Activate For f = 5 To Dest.Cells(Rows.Count, "B").End(xlUp).Row If Dest.Cells(f, "B").Value <> "" Then Dest.Cells(f, "A").Value = f - 4 End If Next f End If Exit Sub End If End If Else MSG = MsgBox("المرجوا التأكد من أسماء أوراق العمل المرغوب جلب البيانات منها ", vbOKOnly + vbExclamation + vbDefaultButton1 + vbApplicationModal, "انتباه") End If Next End Sub هدا الكود في حدث شيت ("All_School") Private Sub Worksheet_Activate() Call ListSheets End Sub ''''''''''''''''''''''''''''''''''''''''''''' Private Sub Worksheet_Change(ByVal Target As Range) Dim rng As Range, LastRow As Long Dim Dest As Worksheet: Set Dest = Sheets("All_School") If Target.Column = 28 Then LastRow = Dest.Range("aa" & Rows.Count).End(xlUp).Row Application.EnableEvents = False For Each rng In Range("AB2:AB" & LastRow) If rng.Value <> "" And rng.Offset(, -1).Value <> "" Then Call All_School End If Next If Application.WorksheetFunction.CountIf(Sheets("All_School").Range("ab2:ab" & LastRow), "<>") = 0 Then Dest.Range("A5:x1000").ClearContents End If Application.EnableEvents = True End If End Sub وهدا في موديول Sub ListSheets() '("AA:AB") في حالة نقل الكود الى ملف اخر تأكد من وجود الجدول في نفس الاعمدة المدكورة '("Table1") وتطابق اسمه مع الاسم الموجود داخل الكود Dim x As Integer Dim WSdata As Worksheet Dim ws As Worksheet: Set ws = Sheets("All_School") Application.ScreenUpdating = False Dim tbl As ListObject Set tbl = ws.ListObjects("Table1") With tbl.DataBodyRange If .Rows.Count > 1 Then .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete End If End With tbl.DataBodyRange.Rows(1).ClearContents x = 2 For Each WSdata In Worksheets If WSdata.Name <> ws.Name Then ws.Cells(x, 27) = WSdata.Name 'column AA x = x + 1 End If Next End Sub Test MH.xlsm Test MH.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Sub Copy_to_another_workbook() Dim ShData As Worksheet, ShDest As Worksheet Dim aRws As Variant, aCols As Variant, lr As Long Const ShCool As String = "3 4 5 6 7 8 9 10 11 12 13" Set ShData = Worksheets("Sheet1") Application.ScreenUpdating = False 'نفس مسار الملف المفتوح Set ShDest = Workbooks.Open(ThisWorkbook.Path & "\أحمد.xlsm").Sheets("Sheet1") lastrow = ShDest.Cells(ShDest.Rows.Count, "C").End(xlUp).Row + 1 ' لتحديد مسار معين قم بتعديل هدا السطر بما يناسبك ' Set ShDest = Workbooks.Open("C:\Users\MOHAMMED HICHAM\Desktop\أحمد.xlsm").Sheets("Sheet1") lr = ShData.Columns("C:L").Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row aRws = Evaluate("row(10:" & lr + 10 & ")") aCols = Split(ShCool) If ShDest.[C10] = Empty Then ShDest.Range("C10").Resize(lr, UBound(aCols)).Value = Application.Index(ShData.Cells, aRws, aCols) Else ShDest.Range("C" & lastrow).Resize(lr, UBound(aCols)).Value = Application.Index(ShData.Cells, aRws, aCols) End If Workbooks("أحمد.xlsm").Close True Application.ScreenUpdating = True End Sub Saad.rar

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

على حسب ما فهمت من اخر تعديل قمت به داخل الكود تمت تجربة الملف ويشتغل بدون ادنى مشكلة Sub TEST() Dim Réf, A(), i&, F&, Y&, K&, last&, Sh As Variant Dim Dest As Worksheet: Set Dest = Sheets("All_School") last = Dest.Cells(Rows.Count, "b").End(xlUp).Row + 1 Application.ScreenUpdating = False For Each Sh In Sheets(Array("kg1", "kg2", "C1", "C2", "C3", "C4", "C5", "C6")) K = Sh.Range("B" & Rows.Count).End(xlUp).Row Réf = Sh.Range("B6:x" & K) For i = 1 To UBound(Réf, 1) Dest.Range("A6:X" & last).ClearContents Y = Y + 1: ReDim Preserve A(1 To UBound(Réf, 2), 1 To Y) For F = 1 To UBound(Réf, 2) A(F, Y) = Réf(i, F) Next Next With Dest Dest.Range("B6").Resize(Y, UBound(A, 1)) = Application.Transpose(A) End With Next Sh For F = 6 To Dest.Cells(Rows.Count, "B").End(xlUp).Row If Dest.Cells(F, "B").Value <> "" Then Dest.Cells(F, "a").Value = F - 5 End If Next F End Sub test05.xlsm

أخي لقد تم تعديل الملف اكثر من 4 مرات. والان نكتشف أن البيانات حتى العود x !!!!!! 1)هل قمت بتجربة الملف في المرفقات 2) لا يمكنني مساعدتك بدون إرفاق الملف الأصلي أو نسخة طبق الأصل. تفاديا لاهدار الوقت بدون فائدة

تفضل جرب لاكن لازم الاخد بالاعتبار عند تشغيله على ملف اخر يجب عليك تعديل مكان تموضع الشيتات مثلا هنا حددنا من الشيت الاول الى الشيت الثالث في ترتيب اوراق العمل For i = 1 To Sheets.Count - 3 وهنا حددنا من الشيت الرابع الى اخر شيت على الملف المرفق For i = 4 To Sheets.Count يتبقى لك تعديلهم بما يناسيك Sub SAVE_PDF1() 'Save an array of sheets '1/2/3 Dim Path As String Path = ThisWorkbook.Path & "\" Application.ScreenUpdating = False For i = 1 To Sheets.Count - 3 Sheets(i).Select ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Path & ActiveSheet.Name & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False Next MsgBox "تم حفظ الملفات بنجاح" End Sub الكود الثاني Sub SAVE_PDF2() 'Save an array of sheets '4/5/6 Dim Chemin As String Application.ScreenUpdating = False With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False .Title = "اختيار مسار حفظ الملفات" If .Show = -1 Then Chemin = .SelectedItems(1) & "\" Else Exit Sub End If For i = 4 To Sheets.Count Sheets(i).Select ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Chemin & ActiveSheet.Name & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False Next End With MsgBox "تم حفظ الملفات بنجاح" End Sub احصاء V3.xlsb

نعم اخي يمكننا فعل دالك تفضل Sub All_School() Dim Réf, A(), i&, F&, Y&, K&, last&, Sh As Variant Dim Dest As Worksheet: Set Dest = Sheets("All_School") last = Dest.Cells(Rows.Count, "a").End(xlUp).Row + 1 Application.ScreenUpdating = False ' يمكنك اظافة اسماء اوراق العمل المرغوب جلب البيانات منها بالطريقة التالية ' For Each Sh In Sheets(Array("class1", "class2", "class3", "class4", "class5", "class6")) 'هنا تمت اظافة 3 اوراق فقط للتجربة For Each Sh In Sheets(Array("class1", "class2", "class4")) K = Sh.Range("B" & Rows.Count).End(xlUp).Row Réf = Sh.Range("B5:E" & K) For i = 1 To UBound(Réf, 1) Dest.Range("A5:E" & last).ClearContents Y = Y + 1: ReDim Preserve A(1 To UBound(Réf, 2), 1 To Y) For F = 1 To UBound(Réf, 2) A(F, Y) = Réf(i, F) Next Next With Dest Dest.Range("B5").Resize(Y, UBound(A, 1)) = Application.Transpose(A) End With Next Sh For F = 5 To Dest.Cells(Rows.Count, "B").End(xlUp).Row If Dest.Cells(F, "B").Value <> "" Then Dest.Cells(F, "a").Value = F - 4 End If Next F End Sub تجميع التلاميذ 4.xlsm

تفضل اخي Sub Save_PDF() 'Save an array of sheets '1/2/3 Dim ws As Variant Dim i As Integer, sh As String Path = ThisWorkbook.Path & "\" Application.ScreenUpdating = False Dim weekSheet As Worksheet For Each ws In Sheets(Array("الأول", "الثاني", "الثالث")) With ws .Activate Set weekSheet = ActiveSheet weekSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Path & weekSheet.Name & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False End With Next For i = 1 To 3 sh = sh & Chr(10) & Chr(10) & ThisWorkbook.Sheets(i).Name Next MsgBox "تم حفظ الملفات بنجاح" & sh, vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "معلومات" Application.ScreenUpdating = True End Sub تفضل استاد Sub Save_PDF2() 'Save an array of sheets '4/5/6 Dim ws As Variant Dim Chemin As String Dim weekSheet As Worksheet With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False .Title = "اختيار مسار حفظ الملفات" If .Show = -1 Then Chemin = .SelectedItems(1) & "\" For Each ws In Sheets(Array("السادس", "الخامس", "الرابع")) With ws .Activate Application.ScreenUpdating = False Set weekSheet = ActiveSheet weekSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Chemin & weekSheet.Name & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False End With Next MsgBox (": تم حفظ الملفات بنجاح في " & vbLf & vbLf & vbLf & .SelectedItems(1)), vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "معلومات" Else Exit Sub End If End With Application.ScreenUpdating = True End Sub بالتوفيق .... احصاء V2.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته هل الملفات يتم حفظها في ورقة pdf واحدة او كل ورقة مستقلة بداتها