نجوم المشاركات

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

شكرا اخى الكريم @خالد المصـــــــــــرى هذا المطلوب وشكرا للجميع شكرا أخى @محمد هشام. تحياتى لك

وعليكم السلام ورحمة الله تعالى وبركاته Public Sub FilterAndCopy() Dim OnRng As Range, n As Long, tmp As Long Dim WS As Worksheet: Set WS = Sheets("اجمالي4") Dim Sh1 As Worksheet: Set Sh1 = Sheets("بنون ناجحون") Dim Sh2 As Worksheet: Set Sh2 = Sheets("بنات ناجحون") tmp = 56 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Sh1.Range("A7:BD" & Sh1.Rows.Count).Clear Sh2.Range("A7:BD" & Sh2.Rows.Count).Clear With WS Set OnRng = .Range("A2:BD" & .Cells(.Rows.Count, "A").End(xlUp).Row) End With With OnRng n = WorksheetFunction.CountIfs(OnRng.Columns(9), "ذكر") If n <> 0 Then .AutoFilter Field:=9, Criteria1:="ذكر" .Offset(1, 0).Resize(.Rows.Count - 1, tmp).Copy Sh1.Range("A7") End If n = WorksheetFunction.CountIfs(OnRng.Columns(9), "انثى") If n <> 0 Then .AutoFilter Field:=9, Criteria1:="انثى" .Offset(1, 0).Resize(.Rows.Count - 1, tmp).Copy Sh2.Range("A7") End If .Parent.AutoFilterMode = False End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub ترحيل بنون ناجحون وترحيل بنات ناجحات.rar

إليك الكود بعد تعديله Public Sub FilterAndCopy() Const tmpCol As String = "BC" Dim OnRng As Range, i As Long, n As Long, r As Long Dim WS As Worksheet, Sh1 As Worksheet, Sh2 As Worksheet Set WS = Sheets("اجمالي4") Set Sh1 = Sheets("بنون ناجحون") Set Sh2 = Sheets("بنات ناجحون") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Sh1.Range("A7:BD" & Sh1.Rows.Count).Clear Sh2.Range("A7:BD" & Sh2.Rows.Count).Clear With WS Set OnRng = .Range("A5:BD" & .Cells(.Rows.Count, "A").End(xlUp).Row) End With n = 7: r = 7 For i = 1 To OnRng.Rows.Count + 1 If InStr(1, WS.Cells(i, tmpCol).Value, "ناجح", vbTextCompare) > 0 Then If WS.Cells(i, 9).Value = "ذكر" Then WS.Range("A" & i & ":BD" & i).Copy Destination:=Sh1.Range("A" & n) n = n + 1 ElseIf WS.Cells(i, 9).Value = "انثى" Then WS.Range("A" & i & ":BD" & i).Copy Destination:=Sh2.Range("A" & r) r = r + 1 End If End If Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub ترحيل بنون ناجحون وترحيل بنات ناجحات.rar

@محمد هشام. حضرتك استاذنا ولا يهمك يا غالى لسا عندى شيتات تانى مستنى ابداعك فيها اخى الكريم

جرب اخي المطلوب.rar

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

@محمد هشام. ارجو الحل

@عبدالله بشير عبدالله ممكن حل

السلام عليكم و رحمة الله اليك الملف ملف1.xlsm

الف شكر لحضرتك استاذ Foksh الكود يعمل بشكل ممتاز جدا [Forms]![Frm_Data_entry]![Frm_Fatura_Main].[Form]![Net_Teams] = [Forms]![Frm_Data_entry]![Frm_Fatura_Main].[Form]![Total_Main_Meter] - [Forms]![Frm_Data_entry]![Frm_Fatura_Sub].[Form]![Total_Sub_Meter] هل اطمع منك فى المزيد هل يوجد تصميم افضل للبرنامج من التصميم الحالى حيث اننى توفقت منذ فترة طويلة جدا حوالى 10 سنوات فى العمل على الاكسيس واكيد هناك تحديثات افضل بكثير تمت فى الفترة الاخيرة لكم منى جزيل الشكر والاحترام

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

لو تعرف احكيلي علشان نلاقي حد يساعدنا

1️⃣ فيما يخص التبويب Print Options :- الأجزاء المظللة باللون الأصفر ( Top , Bottom , Left , Right ) : وظيفتها التحكم بهوامش الصفحة المراد طباعتها . الأجزاء المظللة باللون الأزرق ( Print Data Only ) : يتم طباعة البيانات فقط دون تنسيقات أو إضافات ( مثل الخطوط ، العناوين ، أو النصوص الثابتة ) . الأجزاء المظللة باللون الأخضر ( Print Form Only ، Print Datasheet Only ) : * Print Form Only : لطباعة جزء النموذج فقط . * Print Datasheet Only : لطباعة جزء الجدول أو ورقة البيانات فقط . باختصار هذا الخيار مخصص للنماذج المنقسمة (Split Form) ، حيث يمكن طباعة عرض واحد فقط من النموذج 2️⃣ أما التبويب Columns :- الأجزاء المظللة باللون الأخضر Grid Settings تتيح لك التحكم بعدد الأعمدة المطبوعة في الورقة . على سبيل المثال كما في ( الكتيبات أو التقارير المصفوفة ) ◀ Number of Columns ( عدد الأعمدة ) :- يحدد عدد الأعمدة التي يتم تقسيم الصفحة إليها عند الطباعة . القيمة الافتراضية هي 1 ، ويمكنك زيادتها لطباعة البيانات في عدة أعمدة ( مثل طباعة قائمة عناوين ) . ◀ Row Spacing ( تباعد الصفوف ) :- يحدد المسافة بين كل صف والصف الذي يليه داخل العمود نفسه . يتم قياسه بوحدات القياس المستخدمة ( عادة بالبوصة أو السنتيمتر ) . ◀ Column Spacing ( تباعد الأعمدة ) :- يحدد المسافة بين الأعمدة . يستخدم عند تعيين أكثر من عمود لضمان وجود فراغات مناسبة بينها . الأجزاء المظللة باللون البنفسجي Column Size : ◀ Width ( العرض ) :- يحدد عرض كل عمود . وهو ما قد يؤثر على حجم البيانات المعروضة في العمود . ◀ Height ( الإرتفاع ) :- يحدد ارتفاع العمود . يستخدم لتحديد مساحة القيمة المعروضة داخل العمود. ◀ Same as Detail ( مطابق للتفاصيل ) :- عند تفعيل هذا الخيار ، يتم ضبط أبعاد الأعمدة ( العرض و الارتفاع ) بحيث تكون متطابقة مع تفاصيل التقرير (التخطيط التفصيلي).الأجزاء في اللون البنفسجي ، تسمح لك بالتحكم بعرض وارتفاع المود الواحد في الورقة أو التقرير . وهنا ليس هناك اي قيم محددة بل هي حسب حاجتك . الأجزاء المظللة باللون البرتقالي Column Layout : ◀ Down , then Across ( الإتجاه من الأعلى للأسفل ، ثم عبر الأعمدة ) : حيث يتم ملء البيانات من الأعلى إلى الأسفل في العمود الأول ، ثم ينتقل إلى العمود التالي . ◀ Across , then Down (عبر الأعمدة أولاً ، ثم الإتجاه من الأعلى للأسفل ) : حيث يتم ملء البيانات في الصف الأول من كل الأعمدة ، ثم ينتقل إلى الصف التالي . يعني باختصار شديد هذا التبويب مفيد عند إنشاء تقارير تحتاج إلى تنسيق متعدد الأعمدة ، مثل طباعة بطاقات الأسماء أو قوائم ... إلخ أما فيما يخص مشكلتك مع الأرقام ، فهي باعتقادي تختلف ولن يستطيع أحد معرفة مقاسات وطبيعة تصميم تقاريرك غيرك ؛ فبعد تجربتك المتكررة من التعديل على هذه الارقام ( حسب حاجتك طبعاً ) ستتوصل الى ارقام صحيحة تناسب تصميم تقريرك أو ما تريد طباعته .

جملتك هذه فهمت منها من كلمة نفس الحقول اي اتركها كما هي نتائج المقارنة.xlsb نتائج المقارنة1.xlsb

جرب هدا بعد تنفيد ما سبق دكره سابقا Sub CopyDataOnGroups() Dim lastrow&, r&, Irow& Dim ShtOne As Worksheet, WS As Worksheet Dim rng As Boolean, arr As Variant, tmp As Range Dim lingHeader As Range, cell As Range, data As Variant Dim ColHeader As Range, a As Range, OnRng As Range Dim Group As Boolean, n As Boolean Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set ShtOne = Sheets("التجميع") ShtOne.Range("B3:BD" & ShtOne.Rows.Count).Clear arr = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5") For Each sheetName In arr Set WS = Sheets(sheetName) lastrow = WS.Columns("B:BD").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If lastrow < 1 Then GoTo NextSheet For Each lingHeader In WS.Range("B19", WS.Cells(19, WS.Cells(19, Columns.Count).End(xlToLeft).Column)).Cells If lingHeader.MergeCells Then Set lingHeader = lingHeader.MergeArea.Cells(1, 1) For Each tmp In WS.Range(lingHeader.Offset(1, 0), WS.Cells(20, lingHeader.MergeArea.Columns.Count + lingHeader.Column - 1)) Group = False n = False rng = False For Each ColHeader In ShtOne.Range("B1", ShtOne.Cells(1, ShtOne.Cells(1, Columns.Count).End(xlToLeft).Column)).Cells If ColHeader.MergeCells Then Set ColHeader = ColHeader.MergeArea.Cells(1, 1) If Trim(lingHeader.Value) = Trim(ColHeader.Value) Then Group = True For Each a In ShtOne.Range(ColHeader.Offset(1, 0), _ ShtOne.Cells(2, ColHeader.MergeArea.Columns.Count + ColHeader.Column - 1)) If Trim(tmp.Value) = Trim(a.Value) Then n = True Set OnRng = WS.Range(tmp.Offset(1, 0), WS.Cells(lastrow, tmp.Column)) r = ShtOne.Cells(ShtOne.Rows.Count, a.Column).End(xlUp).Row Irow = r + 1 For Each cell In OnRng data = cell.Value If Application.CountIf(ShtOne.Range(ShtOne.Cells(3, a.Column), ShtOne.Cells(r, a.Column)), data) > 0 Then rng = True Exit For End If Next cell If Not rng Then OnRng.Copy ShtOne.Cells(Irow, a.Column).PasteSpecial Paste:=xlPasteAllUsingSourceTheme Application.CutCopyMode = False End If Exit For End If Next a End If If Group And n Then Exit For Next ColHeader Next tmp Next lingHeader NextSheet: Next sheetName Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub المصنف 4.xlsb

لم انتبه لذلك فعذرا شكرا لدعائك واطرائك الملف بحث بجزء من الإسم (1).xlsb

وعليكم السلام ورحمة الله تعالى وبركاته تفضل أخي سيتم إنشاء مجلد في نفس مسار المصنف بإسم المراكز وحفظ الملفات الجديدة بداخله Public Sub Split_Sheets() Dim fullPath As String, tmp As Collection, rCrit As Variant, Rng As Range, newWb As Workbook Dim AutoFilterWasOn As Boolean, WS As Worksheet, lastRow As Long, cell As Range, s As String Dim Chars As String, i As Integer, col As Integer, f As Worksheet, folder As String Dim fileCount As Integer folder = "المراكز" fullPath = ThisWorkbook.Path & "\" & folder If Dir(fullPath, vbDirectory) = "" Then MkDir fullPath Set WS = ActiveWorkbook.Worksheets("Sheet1") AutoFilterWasOn = WS.AutoFilterMode If AutoFilterWasOn Then WS.AutoFilterMode = False lastRow = WS.Cells(WS.Rows.Count, "D").End(xlUp).Row Set tmp = New Collection On Error Resume Next For Each cell In WS.Range("D3:D" & lastRow) If Not IsNumeric(cell.Value) And Len(cell.Value) > 0 Then tmp.Add cell.Value, CStr(cell.Value) End If Next cell On Error GoTo 0 With Application .ScreenUpdating = False .CopyObjectsWithCells = False .Calculation = xlCalculationManual End With fileCount = 0 For Each rCrit In tmp With WS.Range("B2:H2") .AutoFilter Field:=3, Criteria1:=rCrit End With On Error Resume Next Set Rng = WS.Range("B2:H" & lastRow).SpecialCells(xlCellTypeVisible) On Error GoTo 0 If Not Rng Is Nothing Then Set newWb = Workbooks.Add(xlWBATWorksheet) Set f = newWb.Worksheets(1) s = rCrit Chars = ":\/?*[]" For i = 1 To Len(Chars) s = Replace(s, Mid(Chars, i, 1), "_") Next i If Len(s) > 31 Then s = Left(s, 31) f.Name = s f.DisplayRightToLeft = True Rng.Copy f.Range("B2") For col = 2 To 8 If f.Columns(col).ColumnWidth <> WS.Columns(col).ColumnWidth Then f.Columns(col).ColumnWidth = WS.Columns(col).ColumnWidth End If Next col f.Rows(1).RowHeight = WS.Rows(1).RowHeight Application.DisplayAlerts = False newWb.SaveAs fullPath & "\" & s & ".xlsx", xlOpenXMLWorkbook Application.DisplayAlerts = True newWb.Close False fileCount = fileCount + 1 End If Next rCrit If WS.AutoFilterMode Then WS.AutoFilterMode = False End If With Application .ScreenUpdating = True .CopyObjectsWithCells = True .Calculation = xlCalculationAutomatic End With MsgBox "تم حفظ " & fileCount & " ملفات بنجاح", vbInformation End Sub لقد لاحظت وجود أسماء رقمية في عمود المركز ' في حالة كانت لك رغبة بإنشاء الأوراق الخاصة بها عدل هدا السطر 'من If Not IsNumeric(cell.Value) And Len(cell.Value) > 0 Then 'الى If Len(cell.Value) > 0 Then ترحيل 1 الى شيتات منفصلة v1.xlsb

بعد إدن الأستاد @عبدالله بشير عبدالله تعديل بسيط على الكود الخاص به أخي @reem2009a جرب بهذه الطريقة لا تحتاج لتحديد مسار سطح المكتب. عند تنفيذ الكود سيفتح لك مربع حوار لإختار ملف رقم1 وملف رقم2 مما سيغنيك عن تحديد أسماء المصنفات داخل الكود ربما يناسبك filePath1 = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx", , "Select First File") If filePath1 = "False" Then Exit Sub filePath2 = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx", , "Select Second File") If filePath2 = "False" Then Exit Sub On Error GoTo ErrorHandler Set wb1 = Workbooks.Open(filePath1) Set wb2 = Workbooks.Open(filePath2) Set resultWs = ThisWorkbook.Sheets("Sheet1") resultWs.Cells.ClearContents resultWs.Range("A1:D1").Value = Array("اسم الموظف", "الحالة", _ Left(wb1.Name, InStrRev(wb1.Name, ".") - 1), Left(wb2.Name, InStrRev(wb2.Name, ".") - 1)) 'Code........... End Sub نتائج المقارنة.xlsb

السلام عليكم تم انشاء ملف جديد باسم نتائج المقارنة تم وضع كود به اضغط على الزر فقط بشرط الملفين تشرين وايلول يكونان مقفلين وان بكونا على سطح المكتب بمعنى الملفات الثلاتة على سطح المكتب وبنفس الاسماء الحالية يمكنك تعديل الاسماء من الكود ان اردت Sub CompareSalaries() Dim desktopPath As String Dim wb1 As Workbook, wb2 As Workbook, ws1 As Worksheet, ws2 As Worksheet Dim resultWb As Workbook, resultWs As Worksheet Dim lastRow1 As Long, lastRow2 As Long, i As Long, j As Long Dim empName As Variant Dim salary1 As Double, salary2 As Double Dim dictSalaries1 As Object, dictSalaries2 As Object desktopPath = Environ("UserProfile") & "\Desktop\" Application.ScreenUpdating = False Application.Calculation = xlCalculationManual On Error GoTo ErrorHandler Set wb1 = Workbooks.Open(desktopPath & "__ايلول_.xlsx") Set wb2 = Workbooks.Open(desktopPath & "__تشرين الاول_.xlsx") Set resultWb = Workbooks("نتائج المقارنة.xlsB") Set ws1 = wb1.Sheets("ورقة1") Set ws2 = wb2.Sheets("ورقة1") Set resultWs = resultWb.Sheets("ورقة1") resultWs.Range("A2:D" & resultWs.Rows.Count).ClearContents resultWs.Range("A1:D1").Value = Array("الاسم", "الحالة", "راتب أيلول", "راتب تشرين الأول") Set dictSalaries1 = CreateObject("Scripting.Dictionary") Set dictSalaries2 = CreateObject("Scripting.Dictionary") lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow1 empName = ws1.Cells(i, 1).Value salary1 = ws1.Cells(i, 2).Value dictSalaries1(empName) = salary1 Next i lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow2 empName = ws2.Cells(i, 1).Value salary2 = ws2.Cells(i, 2).Value dictSalaries2(empName) = salary2 Next i j = 2 For Each empName In dictSalaries1.Keys If dictSalaries2.exists(empName) Then salary1 = dictSalaries1(empName) salary2 = dictSalaries2(empName) If salary1 <> salary2 Then resultWs.Cells(j, 1).Value = empName resultWs.Cells(j, 2).Value = "تغير في الراتب" resultWs.Cells(j, 3).Value = salary1 resultWs.Cells(j, 4).Value = salary2 j = j + 1 End If Else resultWs.Cells(j, 1).Value = empName resultWs.Cells(j, 2).Value = "محذوف" resultWs.Cells(j, 3).Value = dictSalaries1(empName) resultWs.Cells(j, 4).Value = "" j = j + 1 End If Next empName For Each empName In dictSalaries2.Keys If Not dictSalaries1.exists(empName) Then resultWs.Cells(j, 1).Value = empName resultWs.Cells(j, 2).Value = "جديد" resultWs.Cells(j, 3).Value = "" resultWs.Cells(j, 4).Value = dictSalaries2(empName) j = j + 1 End If Next empName wb1.Close False wb2.Close False resultWs.Columns("A:D").AutoFit With resultWs.Range("A1:D" & j - 1).Borders .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With MsgBox "تمت المقارنة وتم عرض النتائج في ورقة 'ورقة1' في مصنف 'نتائج المقارنة.xlsx'.", vbInformation Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical If Not wb1 Is Nothing Then wb1.Close False If Not wb2 Is Nothing Then wb2.Close False Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub الملف نتائج المقارنة.xlsb

قواعد المشاركة فى الموقع اضغط هنـــــــــامن فضلك لقراءة القواعد كاملة و بصفة خاصة نؤكدعلى ما يلي 1- يمنع منعا باتا نشر أية مواد تخالف حقوق الملكية الفكرية و يرجى الابلاغ عن المشاركات المخالفة من خلال زر تقرير اسفل المشاركة 2-يجب استخدام خاصيةالبحث قبل طرح السؤال توفيرا للوقت و الجهد. 3-ضرورة كتابة عنوان واضح للموضوع يدل على محتواه ويعطي وصفاً مختصرا للسؤال. 4-ممنوع منعا باتاً كتابة عناوين سينمائية مثل عاجل ، نداء الي فلان ، الي الخبراء ، طلب مساعدة ، أريد حلا..... 5-يمكن استعجال الرد باستخدام تعبير -للرفع- و غير مسموح بالالحاح او اللوم فجميع الاعضاء يشاركون تطوعا طبقا لسعة وقتهم. ومخالفة ذلك تعرض الموضوع للحذف هذا الموضوع مخالف لقوانين المنتدي ×××××××× موضوع مكرر ×××××××× يغلق ××××××××