محمد هشام.

يمكنك استثناء اي ورقة عمل بالطريقة التالية لنفترض اننا اردنا عدم جلب بيانات الورقة 1 والورقة 2 مثلا . If Sheets(sh).Name <> wsData.Name And Sheets(sh).Name <> "ورقة1" And Sheets(sh).Name <> "ورقة2" Then اما بالنسبة لتنسيق عمود المسلسل فقد تمت مراعات دالك داخل الكود Sub All_School() Dim i As Long, sh As Integer, lig As Long, j As Integer Dim wsData As Worksheet: Set wsData = Sheets("All_School") With wsData Application.ScreenUpdating = False .Range("A5:D" & .Range("A" & Rows.Count).End(xlUp).Row + 1).ClearContents For sh = 1 To Sheets.Count If Sheets(sh).Name <> wsData.Name And Sheets(sh).Name <> "ورقة1" Then For i = 5 To Sheets(sh).Range("B" & Rows.Count).End(xlUp).Row + 1 If .Range("B5") = "" Then lig = 5 Else lig = .Range("B" & Rows.Count).End(xlUp).Row + 1 For j = 2 To .Cells(4, Columns.Count).End(xlToLeft).Column .Cells(lig, j) = Sheets(sh).Cells(i, j) For F = 5 To wsData.Cells(Rows.Count, "B").End(xlUp).Row If wsData.Cells(F, "B").Value <> "" Then wsData.Cells(F, "a").Value = F - 4 End If Next F Next Next End If Next End With End Sub تجميع التلاميذ 3.xlsm

هدا بسبب عدم تفريغك للبيانات القديمة لقد تم تزويدك من قبل باكواد اسرع واسهل من هدا بكثير على العموم تفضل تم تعديل المرفق كل عام وانت بخير (2).xlsm

اخي ملفك مليئ بالاخطاء وغير منظم لاكنني ساقوم باصلاح كود الترحيل فقط على حسب طلبك بنفس طريقة اشتغالك قم بوضع الكود هكدا . Private Sub CmdADD_Click() Dim last As Long If Me.TextBox2 = Empty Then: Exit Sub With sheet1 last = .Cells(.Rows.Count, "b").End(xlUp).Offset(1, 0).Row sheet1.Cells(last, "B").Value = Me.TextBox2.Value ' الرقم التعريفي sheet1.Cells(last, "C").Value = Me.TextBox15.Value 'الرقم التسجيل sheet1.Cells(last, "E").Value = Me.TextBox8.Value ' اللقب sheet1.Cells(last, "D").Value = Me.TextBox16.Value 'الاسم sheet1.Cells(last, "G").Value = Me.TextBox10.Value 'مكان الميلاد sheet1.Cells(last, "F").Value = Me.TextBox11.Value 'تاريخ الميلاد sheet1.Cells(last, "AE").Value = Me.TextBox9.Value 'اللقب بالاتننية sheet1.Cells(last, "AF").Value = Me.TextBox17.Value 'الاسم بالاتننية sheet1.Cells(last, "AG").Value = Me.TextBox18.Value 'مكان الميلاد بالاتننية sheet1.Cells(last, "AH").Value = Me.TextBox19.Value 'ولاية sheet1.Cells(last, "AC").Value = Me.TextBox12.Value 'تخصص sheet1.Cells(last, "AD").Value = Me.TextBox20.Value 'تخصص بالاتننية sheet1.Cells(last, "AI").Value = Me.TextBox13.Value ' رقم الوسيط sheet1.Cells(last, "AJ").Value = Me.TextBox21.Value ' رقم هاتف End With Me.TextBox2.Value = "" Me.TextBox15.Value = "" Me.TextBox16.Value = "" Me.TextBox8.Value = "" Me.TextBox10.Value = "" Me.TextBox11.Value = "" Me.TextBox9.Value = "" Me.TextBox17.Value = "" Me.TextBox18.Value = "" Me.TextBox19.Value = "" Me.TextBox12.Value = "" Me.TextBox20.Value = "" Me.TextBox13.Value = "" Me.TextBox21.Value = "" MsgBox "تم ترحيل البيانات بنجاح", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading, "تأكيد" ThisWorkbook.Save End Sub

صراحة لم افهم مادا تقصد يمكنك ارفاق عينة للنتيجة المطلوبة ادا امكن . اظافة لا يوجد اي جدول باسم معرف على الملف اما ادا كنت تقصد ترتيبها بنفس التسلسل الموجود على كل ملف تم تغييره بتسلسل جديد ليتوافق مع شكل الملف لديك في اول مشاركة على العموم ادا كان هدا هو طلبك اجعل الكود بهده الطريقة Sub importer() Dim i As Long, sh As Integer, lig As Long, j As Integer Dim wsData As Worksheet: Set wsData = Sheets("الجميع") With wsData Application.ScreenUpdating = False .Range("A5:D" & .Range("A" & Rows.Count).End(xlUp).Row + 1).ClearContents For sh = 1 To Sheets.Count If Sheets(sh).Name <> wsData.Name Then For i = 5 To Sheets(sh).Range("a" & Rows.Count).End(xlUp).Row + 1 If .Range("a5") = "" Then lig = 5 Else lig = .Range("a" & Rows.Count).End(xlUp).Row + 1 For j = 1 To .Cells(4, Columns.Count).End(xlToLeft).Column .Cells(lig, j) = Sheets(sh).Cells(i, j) Next Next End If Next End With End Sub واي اضافة او تعديل لا تتردد في دكره سوف نكون سعداء لمساعدتك بالتوفيق..

وعليكم السلام ورحمة اله تعالى وبركاته تفضل اخي Sub importer() Dim i As Long, sh As Integer, lig As Long, j As Integer Dim wsData As Worksheet: Set wsData = Sheets("الجميع") With wsData Application.ScreenUpdating = False .Range("A5:D" & .Range("A" & Rows.Count).End(xlUp).Row + 1).ClearContents For sh = 1 To Sheets.Count If Sheets(sh).Name <> wsData.Name Then For i = 5 To Sheets(sh).Range("B" & Rows.Count).End(xlUp).Row + 1 If .Range("B5") = "" Then lig = 5 Else lig = .Range("B" & Rows.Count).End(xlUp).Row + 1 For j = 2 To .Cells(4, Columns.Count).End(xlToLeft).Column .Cells(lig, j) = Sheets(sh).Cells(i, j) [A5] = 1 Range("a5:a" & Range("b" & Rows.Count).End(xlUp).Row).DataSeries , xlDataSeriesLinear Next Next End If Next End With End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 'لجلب البيانات تلقائيا يمكنك وضع هدا الرمز في حدث شيت الجميع Private Sub Worksheet_Activate() Call importer End Sub ملاحظة قد تم وضعه مسبق يكفي فقط تفعيله في حالة الرغبة عن الاستغناء عن الزر لتنفيد الكود v2 تجميع التلاميذ.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته ما عليك سوى تحديد الشيتات المرغوب دمجها كما في الصورة Sub Merge_worksheets() Dim Rng, C, A(), P&, i&, F&, Y&, N&, derligne&, lastrow& Dim DestArr() As String Dim ws As Worksheet: Set ws = Sheets("تجميع") lastrow = ws.Cells(Rows.Count, "a").End(xlUp).Row + 1 N = ws.Range("W" & Rows.Count).End(xlUp).Row Set Rng = ws.Range("W2:W" & N) Application.ScreenUpdating = False If ws.[V2] = Empty Then m = MsgBox("المرجوا تحديث قائمة أسماء الشيتات", vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "انتباه"): Exit Sub On Error Resume Next For Each C In Rng If C Then If C <> "" Then ReDim Preserve DestArr(0 To P) DestArr(P) = C.Offset(, -1).Value P = P + 1 End If End If Next For K = LBound(DestArr) To UBound(DestArr) Worksheets(DestArr(K)).Activate derligne = ActiveSheet.Range("a" & Rows.Count).End(xlUp).Row Rng = ActiveSheet.Range("A5:N" & derligne) For i = 1 To UBound(Rng, 1) ws.Range("A2:N" & lastrow).ClearContents Y = Y + 1: ReDim Preserve A(1 To UBound(Rng, 2), 1 To Y) For F = 1 To UBound(Rng, 2) A(F, Y) = Rng(i, F) Next Next With ws ws.Range("a2").Resize(Y, UBound(A, 1)) = Application.Transpose(A) End With Next On Error GoTo 0 ws.Activate End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub ListSheets() Dim derligne&, x As Integer Dim ws As Worksheet: Set ws = Sheets("تجميع") derligne = ws.Cells(Rows.Count, 22).End(xlUp).Row + 1 Application.ScreenUpdating = False ws.Range("v2:v" & derligne).ClearContents x = 2 For Each WSdata In Worksheets If WSdata.Name <> ws.Name Then ws.Cells(x, 22) = WSdata.Name x = x + 1 End If Next End Sub تجميع V2.xlsm

لابد من تزويدنا بعينة من شكل الملفات المرغوب طباعتها او جرب استخدام خاصية Shell "wiaacmgr.exe", vbNormalFocus يمكنك البحث عنها في النت في ظل غياب المعطيات الكافية ساحاول الانتقال للطلب الثاني والثالث بالنسبة لامكانية عرض بيانات جداول مختلفة والتنقل بينها على نفس الليست بوكس تفضل اخي Dim TB1, f, b, R, Z, Rng, WSData, WS, WS1, WS2() Private Sub UserForm_Initialize() If WS = "" Then Me.ComboBox1.clear For s = 1 To Sheets.Count For Each n In Sheets(s).ListObjects Me.ComboBox1.AddItem n.Name Next n Next s Me.ComboBox1.ListIndex = 0 If TB1 = "" Then TB1 = Me.ComboBox1 Else TB1 = WS WS2 = Array(1, 2, 3, 4, 5, 6) Z = Array(1, 2, 3, 4, 5, 6) R = UBound(WS2) + 1 b = UBound(Z) + 1 Me.ListBox1.ColumnCount = WSData + 1 End If ST End Sub Private Sub ComboBox1_click() TB1 = Me.ComboBox1 Select Case TB1 Case Is = "الصادر" WS2 = Array(1, 2, 3, 4, 5, 6) Z = Array(1, 2, 3, 4, 5, 6) Case Is = "الوارد" WS2 = Array(1, 2, 3, 4, 5, 6) Z = Array(1, 2, 3, 4, 5, 6) End Select WS = Me.ComboBox1 WSData = Range(TB1).Columns.Count R = UBound(WS2) + 1 b = UBound(Z) + 1 ST End Sub Sub ST() WSData = Range(TB1).Columns.Count Rng = Range(TB1).Resize(, WSData + 1).Value For i = 1 To UBound(Rng): Rng(i, WSData + 1) = i: Next i Tb_Text For i = WSData + 1 To 6: Me("textbox" & i).Visible = False: Next i For i = WSData + 1 To 6: Me("label" & i).Visible = False: Next i For i = LBound(Rng) To UBound(Rng): Rng(i, 3) = Format(Rng(i, 3), "dd/mm/yyyy"): Next i ReDim WS1(1 To UBound(Rng)) col = UBound(Rng, 2) For i = LBound(Rng) To UBound(Rng) For Each K In WS2 WS1(i) = WS1(i) & Rng(i, K) & "|" Next K WS1(i) = WS1(i) & Rng(i, col) & "|" Next i Dim TBL(): ReDim TBL(1 To UBound(Rng), 1 To WSData + 1) For i = 1 To UBound(Rng) For c = 1 To WSData: TBL(i, c) = Rng(i, c): Next c TBL(i, c) = Rng(i, WSData + 1) Next i Me.ListBox1.List = TBL Me.ListBox1.ListIndex = -1 Empty_wsData_Click Me.Text_Rech.SetFocus End Sub جاري التعديل (2).xlsm

موضوع مكرر

وعليكم السلام ورحمة الله تعالى وبركاته Private Sub CommandButton1_Click() TextBox2.Value = Format(Range("A2").Value, "dd/mm/yyyy") End Sub

حل اخر في حالة الرغبة بمسح البيانات القديمة وترحيل الجديدة Sub Sheets_Arrays2() ' بالتنسيقات Dim LR&, LR2&, lrow& Dim wsData As Variant Dim Dest As Worksheet: Set Dest = Sheets("eman") lRow = Dest.Cells(Dest.Rows.Count, "C").End(xlUp).Offset(1).Row Application.ScreenUpdating = False Dest.Range("C10:J" & lRow).ClearContents For Each wsData In Sheets(Array("Sheet1", "Sheet2", "Sheet3")) a = wsData.Cells(Rows.Count, "E").End(xlUp).Row b = Dest.Cells(Rows.Count, "C").End(xlUp).Row wsData.Range("E10:F" & a).Copy Dest.Range("C" & b + 1) wsData.Range("H10:H" & a).Copy Dest.Range("E" & b + 1) wsData.Range("J10:J" & a).Copy Dest.Range("F" & b + 1) wsData.Range("L10:M" & a).Copy Dest.Range("G" & b + 1) wsData.Range("P10:Q" & a).Copy Dest.Range("I" & b + 1) Application.ScreenUpdating = True Next wsData End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' قيم Sub Sheets_Arrays3() Dim LR&, LR2& Dim wsData As Variant Dim Dest As Worksheet: Set Dest = Sheets("eman") lrow = Dest.Cells(Dest.Rows.Count, "C").End(xlUp).Offset(1).Row Application.ScreenUpdating = False Dest.Range("C10:J" & lrow).ClearContents For Each wsData In Sheets(Array("sheet1", "sheet2", "sheet3")) LR = wsData.Cells(Rows.Count, "E").End(xlUp).Row LR2 = Dest.Cells(Rows.Count, "C").End(xlUp).Row + 1 With wsData Dest.Range("C" & LR2 & ":d" & LR2 + LR - 10).Value = wsData.Range("E10:F" & LR).Value Dest.Range("E" & LR2 & ":e" & LR2 + LR - 10).Value = wsData.Range("H10:H" & LR).Value Dest.Range("F" & LR2 & ":F" & LR2 + LR - 10).Value = wsData.Range("J10:J" & LR).Value Dest.Range("G" & LR2 & ":h" & LR2 + LR - 10).Value = wsData.Range("L10:M" & LR).Value Dest.Range("I" & LR2 & ":j" & LR2 + LR - 10).Value = wsData.Range("P10:Q" & LR).Value End With Application.ScreenUpdating = True Next wsData End Sub عيد مبارك سعيد2.xlsm

تفضل اخي لاظهار اسماء اوراق العمل او اخفائها استخدم الكود التالي Sub Show_and_hide_sheets() If ActiveWindow.DisplayWorkbookTabs = False Then ActiveWindow.DisplayWorkbookTabs = True Else ActiveWindow.DisplayWorkbookTabs = False End If End Sub

وعليكم السلام ورحمة الله تعالى وبركاته Sub Sheets_Arr() Dim a, b, C As Variant, lr& Dim Dest As Worksheet: Set Dest = Sheets("eman") 'Columns : E,F,H,L,M,P,Q Const r As String = "5 6 8 10 12 13 16 17 " For Each C In Sheets(Array("Sheet1", "Sheet2", "Sheet3")) lastrow = Dest.Cells(Dest.Rows.Count, "C").End(xlUp).Row + 1 Application.ScreenUpdating = False lr = C.Columns("A:Q").Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row a = Evaluate("row(10:" & lr + 10 & ")") b = Split(r) Dest.Range("c" & lastrow).Resize(lr, UBound(b)).Value = Application.Index(C.Cells, a, b) Application.ScreenUpdating = True Next C End Sub عيد مبارك سعيد.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Sub Filtre() Dim ws1 As Worksheet: Set ws1 = Sheets("Raw Data") Dim ws2 As Worksheet: Set ws2 = Sheets("list filter") Application.ScreenUpdating = False On Error Resume Next ws1.ShowAllData '(B)'المعيار الاول عمود '--- Iso_Spool n = Application.CountA(ws2.Range("A2:A5")) If n > 0 Then Tbl = Application.Transpose(ws2.[A2].Resize(n)) ws1.[A4].AutoFilter Field:=2, Criteria1:=Tbl, Operator:=xlFilterValues End If '(C)'المعيار الثاني عمود '--- Spool2 n = Application.CountA(ws2.Range("B2:B5")) If n > 0 Then Tbl = Application.Transpose(ws2.[B2].Resize(n)) ws1.[A4].AutoFilter Field:=3, Criteria1:=Tbl, Operator:=xlFilterValues End If '(E)'المعيار الثالث عمود '--- IdentCode n = Application.CountA(ws2.Range("C2:C5")) If n > 0 Then Tbl = Application.Transpose(ws2.[C2].Resize(n)) ws1.[A4].AutoFilter Field:=5, Criteria1:=Tbl, Operator:=xlFilterValues End If End Sub TEST V3.xlsm

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

أعتذر السبب هو الفرق في تنسيق التاريخ وتقويم اللغة على الجهاز قم بتغييرها فقط إلى =IF($F$10<>"";"30/"&TEXT($F$10;"mm/aaaa");"") طلبك يتمثل في كتابة اي تاريخ بالنسبة لاقتراح الاخ @أبوأحـمـد ممكن يفيدك لاكن مشكلته عند تغيير التاريخ الى شهر 2 لن يشتغل معك بالشكل الصحيح .عكس المعادلة الأولى DATE 30-2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته =IF($F$10<>"";"30/"&TEXT($F$10;"mm/aaaa");"") ");"") اخر يوم في الشهر =EOMONTH($F$10;0)

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

إليك حل اخر لفلترة البيانات بعدة معايير Option Explicit Public Sub Filter_data() Dim lo As ListObject, rng As Range Dim rw As Long, i As Long Dim arrayCriteria() Set lo = Range("Clé").ListObject rw = lo.ListRows.Count ReDim arrayCriteria(rw) For i = 1 To rw arrayCriteria(i) = CStr(lo.DataBodyRange.Cells(i, 1)) Next i Set rng = Range("Tbl") With rng.ListObject If .ShowAutoFilter Then .AutoFilter.ShowAllData .Range.AutoFilter field:=2, Criteria1:=arrayCriteria, Operator:=xlFilterValues End With End Sub '''''''''''''''''''''''''''''''''''''''''' Public Sub Reset_filter() Dim rng As Range Set rng = Range("Tbl") With rng.ListObject If .ShowAutoFilter Then .AutoFilter.ShowAllData End With End Sub TEST V2.xlsm

تفضل جرب اخي فلترة البيانات بقيمة الخلية (A1) يمكنك استخدام الكود التالي Sub Filter_Data() Dim Rng As Range Dim Crite As Worksheet: Set Crite = Sheets("Raw Data") Dim CFilter As Worksheet: Set CFilter = Sheets("Do Not Include") lrow = Crite.Range("B" & Rows.Count).End(xlUp).Row Réf = CFilter.[A1] On Error Resume Next If Réf = Empty Then: Exit Sub Crite.AutoFilter.ShowAllData Set Rng = Crite.Range("B6:B" & lrow).Find("*", Réf, LookIn:=XlFindLookIn.xlFormulas, _ lookat:=xlWhole, _ SearchDirection:=xlPrevious) Application.ScreenUpdating = False Crite.Range("A4:E" & lrow).AutoFilter Field:=2, Criteria1:=Réf Crite.Activate On Error GoTo 0 Application.ScreenUpdating = True End Sub test 8.xlsm

تفضل اخي ربما هدا ما تقصده Sub ChangeColor() Dim lrow& Dim WS1 As Worksheet: Set WS1 = Sheets("Raw Data") Dim WS2 As Worksheet: Set WS2 = Sheets("Do Not Include") lrow = WS1.Range("B" & Rows.Count).End(xlUp).Row Rng = WorksheetFunction.CountA(WS1.Range("A4", WS1.Range("A4").End(xlDown))) + 3 Application.ScreenUpdating = False WS1.Activate WS1.Range(Cells(5, 2), Cells(Rng, 2)).Interior.ColorIndex = 0 If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then ActiveSheet.ShowAllData End If Set r = WS1.Range("B5:B" & lrow) For Each cell In r If cell.Value = WS2.Range("A1") Then cell.Interior.Color = RGB(34, 153, 166) cell.Select End If Next Application.ScreenUpdating = True End Sub test 7.xlsm

المفروض انك لا تقوم برفع الملف وطلب المساعدة حتى تتاكد من الانتهاء من تصميمه تفاديا لاهدار الوقت والاشتغال على الملف اكثر من مرة Sub CopyData() Dim x, y(), i&, lr&, a&, r& Set sh1 = ThisWorkbook.Worksheets("شيت") Set sh2 = ThisWorkbook.Worksheets("دور ثان") lr = sh1.Range("a" & Rows.Count).End(xlUp).Row lr2 = sh2.Cells(sh2.Rows.Count, "a").End(xlUp).Offset(1).Row Application.ScreenUpdating = False ' نطاق البيانات x = sh1.Range("A7:H" & lr) For i = 1 To UBound(x, 1) 'H' الشرط في العمود If x(i, 8) = "دور ثاني" Then r = r + 1: ReDim Preserve y(1 To UBound(x, 2), 1 To r) For a = 1 To UBound(x, 2) y(a, r) = x(i, a) Next End If Next With sh2 ' افراغ البيانات السابقة sh2.Range("A7:H" & lr2).ClearContents ' لصق البيانات sh2.[A7].Resize(r, UBound(y, 1)) = Application.Transpose(y) 'تسطير الجدول F = sh2.Range("A65500").End(xlUp).Row G = sh2.Cells(7, Columns.Count).End(xlToLeft).Column sh2.Range("A7:H" & lr2).Borders.LineStyle = xlNone sh2.Range(Cells(7, 1), sh2.Cells(F, G)).Borders.Weight = xlThin End With Application.ScreenUpdating = True End Sub ولنسخ البيانات الى ورقة لا تتضمن رؤوس اعمدة هدا مثال لاستدعاء الناجحين Sub CopyData2() Dim rAlt As Range Dim x, y(), i&, lr&, a&, r&, n& Set sh1 = ThisWorkbook.Worksheets("شيت") Set sh2 = ThisWorkbook.Worksheets("ناجح") lr = sh1.Range("a" & Rows.Count).End(xlUp).Row lr2 = sh2.Cells(sh2.Rows.Count, "a").End(xlUp).Offset(1).Row Application.ScreenUpdating = False sh1.Activate 'نسخ رؤؤوس الاعمدة Set rAlt = sh1.Range("A1:H6") For n = 1 To 8 Set rAlt = Union(rAlt, Intersect(rAlt.EntireRow, Columns(n))) Next n 'لصق rAlt.COPY Destination:=sh2.Range("A1") x = sh1.Range("A7:H" & lr) For i = 1 To UBound(x, 1) ' المعيار If x(i, 8) = "ناجح" Then r = r + 1: ReDim Preserve y(1 To UBound(x, 2), 1 To r) For a = 1 To UBound(x, 2) y(a, r) = x(i, a) Next End If Next sh2.Activate 'لصق في الصف السابع [A7].Resize(r, UBound(y, 1)) = Application.Transpose(y) ' تسطير حدود البيانات F = sh2.Range("A65500").End(xlUp).Row G = sh2.Cells(7, Columns.Count).End(xlToLeft).Column Range("A7:H1000").Borders.LineStyle = xlNone Range(Cells(7, 1), Cells(F, G)).Borders.Weight = xlThin ' تنسيق الاعمدة Columns("A:H").EntireColumn.AutoFit Application.ScreenUpdating = True End Sub v2 خالد.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن الاخوة الكرام اليك اخي حل اخر استدعاء الراسبين الى ورقة دور ثاني في حالة الوجود المسبق لرؤوس عناوين الاعمدة Sub CopyData1() Dim x, y(), i&, lr&, a&, r& Set sh1 = ThisWorkbook.Worksheets("شيت") Set sh2 = ThisWorkbook.Worksheets("دور ثان") lr = sh1.Range("a" & Rows.Count).End(xlUp).Row lr2 = sh2.Cells(sh2.Rows.Count, "a").End(xlUp).Offset(1).Row Application.ScreenUpdating = False x = sh1.Range("A7:AN" & lr) For i = 1 To UBound(x, 1) If x(i, 40) = "دور ثاني" Then r = r + 1: ReDim Preserve y(1 To UBound(x, 2), 1 To r) For a = 1 To UBound(x, 2) y(a, r) = x(i, a) Next End If Next With sh2 sh2.Range("A7:AN" & lr2).ClearContents sh2.[A7].Resize(r, UBound(y, 1)) = Application.Transpose(y) F = sh2.Range("A65500").End(xlUp).Row G = sh2.Cells(7, Columns.Count).End(xlToLeft).Column sh2.Range("A7:AN" & lr2).Borders.LineStyle = xlNone sh2.Range(Cells(7, 1), sh2.Cells(F, G)).Borders.Weight = xlThin End With Application.ScreenUpdating = True End Sub ولنسخ البيانات الى ورقة لا تتضمن رؤوس اعمدة يمكنك استخدام الكود التالي Sub CopyData2() Dim rAlt As Range Dim x, y(), i&, lr&, a&, r&, n& Set sh1 = ThisWorkbook.Worksheets("شيت") Set sh2 = ThisWorkbook.Worksheets("Sheet3") lr = sh1.Range("a" & Rows.Count).End(xlUp).Row lr2 = sh2.Cells(sh2.Rows.Count, "a").End(xlUp).Offset(1).Row Application.ScreenUpdating = False Set rAlt = sh1.Range("A1:AN6") For n = 1 To 40 Set rAlt = Union(rAlt, Intersect(rAlt.EntireRow, Columns(n))) Next n rAlt.COPY Destination:=sh2.Range("A1") x = sh1.Range("A7:AN" & lr) For i = 1 To UBound(x, 1) If x(i, 40) = "دور ثاني" Then r = r + 1: ReDim Preserve y(1 To UBound(x, 2), 1 To r) For a = 1 To UBound(x, 2) y(a, r) = x(i, a) Next End If Next sh2.Activate [A7].Resize(r, UBound(y, 1)) = Application.Transpose(y) F = sh2.Range("A65500").End(xlUp).Row G = sh2.Cells(7, Columns.Count).End(xlToLeft).Column Range("A7:an100").Borders.LineStyle = xlNone Range(Cells(7, 1), Cells(F, G)).Borders.Weight = xlThin Columns("A:AN").EntireColumn.AutoFit Columns("H:AM").EntireColumn.Hidden = True Application.ScreenUpdating = True End Sub V1 خالد.xlsb

Sub Uniques() Dim Rng As Range, derlig& Dim WSDest As Worksheet: Set WSDest = Sheets("Sheet1") derlig = WSDest.Range("a" & Rows.Count).End(xlUp).Row + 1 WSDest.Range("c2:c" & derlig).ClearContents For Each Rng In Range("A2:A" & derlig) If WorksheetFunction.CountIf(Range("B2:B" & derlig), Rng) = 0 Then Range("C" & Rows.Count).End(xlUp).Offset(1) = Rng End If Next End Sub TEST_Uniques.xlsm

تفضل استاد @محمد مصطفى درويش Public Sub SAVE_PDF() Dim SH As Worksheet Dim WSdest As String Dim wsName As Variant Const cstrDel As String = "," Application.ScreenUpdating = False For Each SH In Worksheets If SH.Index >= 8 Then WSdest = WSdest & SH.Name & cstrDel End If Next SH ' 'PDF اسم ملف wsName = "البطاقات" Worksheets(Split(Left(WSdest, Len(WSdest) - 1), cstrDel)).Select ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=ThisWorkbook.Path & "\" & wsName, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False Sheet1.Select Application.ScreenUpdating = True MsgBox "تم حفظ" & " " & Application.Sheets.Count - 7 & " " & "بطاقة ", Exclamation, "officena" End Sub ملف الطالب 2.rar

تفضل استاد @محمد مصطفى درويش يمكنك استخدام الكود التالي مع الاخد بالاعتبار ان وقت تنفيد الكود من الممكن ان يصل الى دقيقتين او اكثر بسبب العدد الكبير للشيتات المحفوظة Sub Save_PDF() Dim i As Byte Path = ThisWorkbook.Path & "\" temps = Timer Application.ScreenUpdating = False Dim weekSheet As Worksheet For i = 8 To Worksheets.Count With Sheets(i).Select Set weekSheet = ActiveSheet weekSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Path & weekSheet.Name & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False End With Next Sheet1.Activate Application.ScreenUpdating = True MsgBox "تم حفظ" & " " & Application.Sheets.Count - 7 & " " & "بطاقة " & "-" & "تم تنفيد الكود في: " & Format(Timer - temps, "0.0000") & "ثانية", Exclamation, "Officena" End Sub ملف الطالب.rar