محمد هشام.

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

تفضل اخي اليك حل اخر ربما هدا ما تقصده Sub OterDoublons() Dim der As Long, j As Long, Lastrow As Long Application.ScreenUpdating = False Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("البيانات") Dim desWS As Worksheet: Set desWS = ThisWorkbook.Sheets("ارقام") Lastrow = WS.Cells(WS.Rows.Count, "O").End(xlUp).Row desWS.Range("A2:C" & Rows.Count).ClearContents WS.Range("O2:Q" & Lastrow).Copy _ Destination:=desWS.Range("A2") With desWS If .FilterMode Then .ShowAllData For j = 1 To Range("C2").Column der = .Cells(.Rows.Count, j).End(xlUp).Row If der >= 2 Then .Cells(1, j).Resize(der).RemoveDuplicates Columns:=1, Header:=xlYes Next j End With Application.ScreenUpdating = True End Sub جلب التفاصيل V2.xlsm

تفضل حل اخر لاثراء الموضوع Sub Filter_month2() Dim Cpt As Long, rgFound As Range Dim cel As Range, Rng As Range, Clé As Range Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("1") Dim desWS As Worksheet: Set desWS = ThisWorkbook.Sheets("2") lastRow = WS.Range("B" & Rows.Count).End(xlUp).Row Set Clé = desWS.Range("L2") Set Rng = WS.Range("B3:B" & lastRow) For Each cel In Rng If Month(cel) = Month(Clé) Then Set rgFound = cel Exit For End If Next cel If rgFound Is Nothing Then MsgBox "لا توجد بيانات لشهر" & " :" & Month(Clé), vbOKOnly + vbExclamation, "admin" Exit Sub End If desWS.Range("B5:M" & Rows.Count).ClearContents For Col = 3 To lastRow If IsDate(WS.Range("B" & Col).Value) = True Then If Month(WS.Range("B" & Col).Value) = Month(Clé) Then Cpt = desWS.Range("b" & Rows.Count).End(xlUp).Row + 1 desWS.Range("B" & Cpt & ":M" & Cpt).Value = WS.Range("A" & Col & ":L" & Col).Value End If End If Next Application.ScreenUpdating = True End Sub

ادن اخي يجب التحقق اولا من تنسيق خلية اسم الشهر .اليك الملف عليه الكود يمكنك تطويعه بما يناسبك Sub Filter_month() Dim lr&, i&, j&, c& Dim arr As Variant, K As Variant Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("1") Dim desWS As Worksheet: Set desWS = ThisWorkbook.Sheets("2") lastrow = desWS.Range("b" & Rows.Count).End(xlUp).Row clé = desWS.[L2] If clé = 0 Then MsgBox "المرجوا تحديد شهر الفلترة", vbExclamation: Exit Sub Application.ScreenUpdating = False lr = WS.Range("B" & Rows.Count).End(xlUp).Row On Error Resume Next arr = WS.Range("A3:L" & lr).Value ReDim K(1 To UBound(arr, 1), 1 To UBound(arr, 2)) j = 1 For i = LBound(arr, 1) To UBound(arr, 1) If Month(arr(i, 2)) = Month(clé) Then desWS.Range("B5:M" & Rows.Count).ClearContents For c = LBound(arr, 2) To UBound(arr, 2) K(j, c) = arr(i, c) Next c j = j + 1 End If Next i desWS.Range("b5").Resize(j - 1, UBound(K, 2)).Value = K If Err <> 0 Then MsgBox "لا توجد بيانات لشهر" & " :" & Month(clé), vbExclamation, "admin" End Sub Filter_month.xlsb

شكرا لك اخي الكريم يسعدنا اننا استطعنا مساعدتك بالتوفيق🫡

ممكن توضح طلبك اكثر او ارفاق عينة لشكل النتيجة المتوقعة

الملف يتم حفظه فعلا في نفس مسار الملف هل تقصد حفظه في مجلد معين او انشاء مجلد جديد في نفس مسار الملف

تفضل اخي قد تم تنفيد المطلوب على الملف المرفق بالنسبة لطلب كود انشاء اوراق عمل باسماء المقاولين ونسخ بياناتهم يمكنك استخدام الكود التالي والدي قد تمت اظافته مسبقا على الملف مع بعض الاكواد الاظافية ستجدها داخل الملف يمكنك اختيار ما يناسبك Sub CreateSheets() Dim desWS As Worksheet: Set desWS = ThisWorkbook.Sheets("الشغل") Dim Col As Range, Sh As Collection, rng As Range, arr As Variant Dim cell As Range, lr As Long, ws As Worksheet Dim Clé As Variant, s As String, SheetName As String Set Col = desWS.Range("C5:C" & desWS.Cells(desWS.Rows.Count, "C").End(xlUp).Row) Set Sh = New Collection With Application .ScreenUpdating = False .DisplayAlerts = False Msg = MsgBox(" تحديث العقود " & " " & "؟", vbYesNo, "Admin") If Msg <> vbYes Then Exit Sub desWS.ListObjects(1).ShowAutoFilter = False '*********' قم باظافةاسماء اوراق العمل الغير مرغوب حدفها من المصنف هنا************** SheetName = "الشغل,the report,النسب ,القائمة" '*********************************************************************************** For Each ws In Worksheets If InStr(1, SheetName, ws.Name) = 0 Then F = Application.Match(ws.Name, arr, 0) If IsError(F) Then ws.Delete End If End If Next ws On Error Resume Next For Each cell In Col.Cells Sh.Add cell.Value, CStr(cell.Value) Next cell On Error GoTo 0 For Each Clé In Sh s = Clé Sheets.Add(After:=Sheets(Sheets.Count)).Name = Clé ActiveSheet.DisplayRightToLeft = True With desWS.Range("A5:O5") .AutoFilter 3, Clé, xlFilterValues lr = desWS.Columns("C:C").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set rng = desWS.Range("A4:O" & lr).SpecialCells(xlCellTypeVisible) rng.Copy Sheets(s).Cells(Rows.Count, "A").End(xlUp).Offset(3) .AutoFilter For Each Cpt In Worksheets If InStr(1, SheetName, Cpt.Name) = 0 Then F = Application.Match(Cpt.Name, arr, 0) If IsError(F) Then For i = 1 To 15 Cpt.Columns(i).ColumnWidth = desWS.Columns(i).ColumnWidth Cpt.Rows(i).RowHeight = desWS.Rows(i).RowHeight Next End If End If Next Cpt Sheets(s).Activate Cells.Interior.Color = xlNone With ActiveWindow .SplitColumn = 3: .SplitRow = 0 ActiveWindow.FreezePanes = True End With End With Next Clé desWS.Activate .ScreenUpdating = True .DisplayAlerts = True End With Contractors End Sub بالتوفيق ............ الاعمال الجنوبية userform 2.xlsm

هل تقصد انشاء اوراق عمل باسم المقاولين ونسخ بياناتهم ادا كان هدا هو طلبك هل سيتم ترحيل اعمدة معينة ؟ او ترحيل من A الى O

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

للتوضيح : لاسخراج جميع الاوراق في ملف PDF واحد يتضمن جميع الطلاب ربما يتعين عليك مثلا نسخ جميع الاوراق المطبوعة لورقة اخرى اسفل بعضها البعض لتتمكن من حفظها بعد دالك . وهدا يتطلب اظافة ورقة جديدة للمصنف مع انشاء الكود الخاص بدالك . اما في حالة الرغبة في حفظها مستقلة اليك الكود التالي سيقوم بحفظ كل ورقة لوحدها في مجلد باسم شهادات الطلاب بعد تسمية كل ملف باسم الطالب الخاص به Private Sub CommandButton1_Click() Dim i As Integer, fPath As String, F As String Dim WS As Worksheet: Set WS = Sheet31 'Sheets("Sheet3 (2)") ' اسم ورقة العمل Application.ScreenUpdating = False For i = [AA12] To [AC12] If i <= [AA1] Then [AF2] = 2 * (i - 2) + 3 F = [B8] ' اسم الملف On Error Resume Next With ActiveWorkbook ' قم بتعديل اسم المجلد بما يناسبك fPath = .Path & Application.PathSeparator & "شهادات الطلاب" & Application.PathSeparator If Len(Dir(fPath, vbDirectory)) = 0 Then End If MkDir fPath WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fPath & "\" & F & ".pdf", OpenAfterPublish:=False 'طباعة 'WS.PrintOut End With Next i Application.ScreenUpdating = True End Sub 666 PDF.xlsm

من االافضل دكر ما هي النتيجة المتوقعة من الكود جرب ربما هدا ما تقصد Sub HideRowsPrint() Dim i As Long, LastRow As Long Application.ScreenUpdating = False StartRow = 9: LastRow = 300 For i = LastRow To StartRow Step -1 If Cells(i, "C") = "" Then Rows(i).Hidden = True Next i Application.ScreenUpdating = True ActiveSheet.PrintPreview ' ActiveSheet.PrintOut Rows(StartRow & ":" & LastRow).EntireRow.Hidden = False End Sub

وعليكم السلام ورحمة الله تعالى وبركاته Sub SaveFile_Excel() 'في نفس مسار المصنف الرئيسي Excel 'حفظ بصيغة Dim WS As Worksheet, Client As String, path As String, Msg As Variant path = ThisWorkbook.path & "\" Set WS = Worksheet____3: Client = [D3].Value If Len([D3].Value) = 0 Then: MsgBox "المرجوا إظافة إسم العميل", vbExclamation, "Admin": Exit Sub Msg = MsgBox(" تصدير الملف" & " : " & "فاتورة" & " " & Client & "؟", vbYesNo, "Admin") If Msg <> vbYes Then Exit Sub With Application .ScreenUpdating = False .DisplayAlerts = False WS.Copy Set rng = [B1:F22] With rng .Value = .Value .Validation.Delete End With For Each shape In ActiveSheet.Shapes shape.Delete Next Application.ActiveWorkbook.SaveAs Filename:=path & Client & ".xlsx", FileFormat:=51 '<-- اظافة التوقيت ' Application.ActiveWorkbook.SaveAs Filename:=Path & Client & "-" & Format(Time, "HH-mm-ss") & ".xlsx", FileFormat:=51 ActiveWorkbook.Close .ScreenUpdating = True .DisplayAlerts = True End With MsgBox "تم نسخ الملف بنجاح" & _ "", vbInformation, Client End Sub حسابات احمد.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا المثال البسيط يمكنك تعديله بما يناسبك مثال _حساب عدد مرات الطباعة.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن الاخ @abouelhassan بما انك ترغب بتنفيد المعادلات على شكل كود اليك حل اخر رغم انني لا اعلم ما هي الطريقة المطلوبة لتنفيده Sub sheets_arrformula() 'Execute On All Worksheets Dim wsName As Worksheet, desWS As Worksheet Dim lr As Long, lige As Long Dim ws As Worksheet: Set ws = Sheets("بيانات رئيسية") For Each wsName In ThisWorkbook.Worksheets If wsName.Name Like "*-JAN" Then 'في حالة اظافة اوراق اخرى للمصنف 'Example February March.......... 1-Feb ,2-Feb.......1-Mar ,2-Mar 'If wsName.Name Like "*-*" Then With Application .ScreenUpdating = False .Calculation = xlManual Set desWS = ThisWorkbook.Sheets(wsName.Name) lr = ws.Columns("A:D").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set a = ws.Range("A2:A" & lr): Set b = ws.Range("B2:B" & lr) Set c = ws.Range("C2:C" & lr): Set d = ws.Range("D2:D" & lr) f = ws.Name lige = desWS.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row - 1 desWS.Range("B2:C" & lige).ClearContents With desWS.Range("B2:B" & lige) .Formula2 = "=IFERROR(INDEX('" & f & "'!" & c.Address & ",MATCH(1,(E$1 ='" & f & "'!" & a.Address & ")*(A2 ='" & f & "'!" & b.Address & "),0)),"""")" .Value = .Value With desWS.Range("C2:C" & lige) .Formula2 = "=IF($B2<>"""",SUMIFS('" & f & "'!" & d.Address & ",'" & f & "'!" & a.Address & ",""=""&$E$1,'" & f & "'!" & c.Address & ",""=""&$B2,'" & f & "'!" & b.Address & ",a2),"""")" .Value = .Value End With End With .ScreenUpdating = True .Calculation = xlAutomatic End With End If Next wsName End Sub ولتنفيد الكود على الورقة النشطة Sub Test2() 'Execute On the Active Worksheet Dim lr As Long, lige As Long Dim ws As Worksheet: Set ws = Sheets("بيانات رئيسية") Dim desWS As Worksheet: Set desWS = ActiveSheet With Application .ScreenUpdating = False .Calculation = xlManual lr = ws.Columns("A:D").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row f = ws.Name Set a = ws.Range("A2:A" & lr): Set b = ws.Range("B2:B" & lr) Set c = ws.Range("C2:C" & lr): Set d = ws.Range("D2:D" & lr) If desWS.Name <> f Then lr = ws.Columns("A:D").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set a = ws.Range("A2:A" & lr): Set b = ws.Range("B2:B" & lr) Set c = ws.Range("C2:C" & lr): Set d = ws.Range("D2:D" & lr) f = ws.Name lige = desWS.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row - 1 desWS.Range("B2:C" & lige).ClearContents With desWS.Range("B2:B" & lige) .Formula2 = "=IFERROR(INDEX('" & f & "'!" & c.Address & ",MATCH(1,(E$1 ='" & f & "'!" & a.Address & ")*(A2 ='" & f & "'!" & b.Address & "),0)),"""")" .Value = .Value With desWS.Range("C2:C" & lige) .Formula2 = "=IF($B2<>"""",SUMIFS('" & f & "'!" & d.Address & ",'" & f & "'!" & a.Address & ",""=""&$E$1,'" & f & "'!" & c.Address & ",""=""&$B2,'" & f & "'!" & b.Address & ",a2),"""")" .Value = .Value End With End With End If .ScreenUpdating = True .Calculation = xlAutomatic End With End Sub مصنف v2.xlsm

https://streamable.com/812u1n ربما عليك التاكد من اعدادات لغة النظام لديك والتحقق من اظافة اللغة العربية حاول مراجعة الرابط التالي : https://sigma-4pc.com/5175/solve-problem-arabic-language

وعليكم السلام ورحمة الله تعالى وبركاته بما ان البيانات من على النمودج ثابثة باستثناء( نوع الطلبية _ والوقت _ و رقم الطلبية) يمكنك محاولة ادراج ملخص الطلبية مباشرة بدون الاعتماد عليه جرب هدا الحل ربما يناسبك Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo Exitsub If Target.Row > 1 And Target.Column < 17 Then Dim lr As Long, r As Long Set WS = Sheet1 lr = WS.Range("i" & Rows.Count).End(xlUp).Row Application.ScreenUpdating = False With WS.Range("r2:r" & lr) .Formula = "=IF(I2<>"""",""في تمام الساعة( ""&CONCATENATE(TEXT(L2,""HH:mm"")&"" ) ""&""تم طلب "")&I2&"" ""&""منطقة (""&A2&"") "" &""وصول""&"" ""&"" ""&I2&"" ""&""الساعة""&"" ( ""&CONCATENATE(TEXT(N2,""HH:mm"")&"")""&"" ""&"" رقم الطلبية ( "")&F2&"") "","""")" .Value = .Value End With For r = 2 To WS.Cells(Rows.Count, "r").End(xlUp).Row If WS.Range("i" & r).Value = "" Then WS.Range("r" & r).Value = "" Next r End If Exitsub: End Sub نموذج V1.xlsm

Private Sub CommandButton4_Click() Dim WS As Worksheet: Set WS = Sheets("Home") Dim dest As Worksheet: Set dest = Sheets("Daily") Dim search As Range, Rng As Range Set search = WS.[F13]: Set Rng = WS.[F4:F13] If Application.WorksheetFunction.CountA(Rng) = 0 Or search = Empty Then MsgBox "المرجوا إدخال البيانات", vbExclamation, "Admin" Exit Sub Else If Application.WorksheetFunction.CountIf(dest.Range("j:j"), search) > 0 Then MsgBox " تم حفظ هذا اليوم مسبقا" & " " & search, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه": Exit Sub a = Array([F4], [F5], [F6], [F7], [F8], [F9], [F10], [F11], [F12], [F13]) dest.[a65000].End(xlUp).Offset(1).Resize(, 10) = a dest.Range("j4:j" & Rows.Count).NumberFormat = "dd/mm/yyyy" Rng.ClearContents MsgBox "تم حفظ البيانات بنجاح" & " " & search & " " & "بنجاح", _ vbInformation, "Done" End If End Sub تقرير بورتوفيق.xlsm

جرب هدا الحل بعد اظافة اليوزرفورم هل يناسبك باسوورد 0 الاعمال الجنوبية userform.xlsm

اظن ان دالك بسبب طريقة تصميمك للملف حاول فلترة بياناتك يدويا ستجد نفس التداخل في العناصر المدكورة

في حدث Private Sub Worksheet_Activate ضع الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) Dim a, i&, k&, b$, S$, lRow& Dim WS As Worksheet: Set WS = Sheets("البيانات") Dim desWS As Worksheet: Set desWS = Sheets("البحث") b = desWS.[E2] On Error Resume Next Application.ScreenUpdating = False If Not Intersect(Target, Target.Worksheet.Range("E2")) Is Nothing Then If Target.Cells.Value = "" Or IsEmpty(Target) Then Exit Sub desWS.Range("A5:j" & Rows.Count).ClearContents a = WS.Range("A3:J" & WS.[a65000].End(xlUp).Row) For i = 1 To UBound(a) If a(i, 4) = b Or a(i, 7) = b Or a(i, 10) = b Then desWS.Cells(k + 5, 1).Resize(, 10) = Application.IfError(Application.Index(a, i, Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)), "") k = k + 1 ActiveWindow.DisplayZeros = False End If Next lRow = desWS.Range("A:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set Rng = desWS.Range("A5 :J" & lRow) desWS.Range("A5:J500").Borders.LineStyle = xlNone For Each c In Rng.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next Application.ScreenUpdating = True End If End Sub السيارات 24.xlsb

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

يسعدنا اننا استطعنا مساعدتك 😁 بالنسبة للماكرو يمكنك حدفه لا علاقة له بالمطلوب

ربما لم تنتبه للكود اذا اردت الاشتغال على ورقة 2 قم بتعديل هذا السطر لان البيانات يتم جلبها من ورقة 1 Set WS = Worksheets("Sheet1"): Set desWS = Worksheets("Sheet2") الى Set WS = Worksheets("Sheet2"): Set desWS = Worksheets("Sheet2") او تعديله بالكامل بالشكل التالي Option Explicit Public Sub TransposeData2() Dim desWS As Worksheet, rng As Variant Dim Cpt() As Variant, I As Long, J As Long, k As Long, loc As String Set desWS = Worksheets("Sheet2") Application.ScreenUpdating = False rng = desWS.[C6:O10].Value2 For I = 2 To UBound(rng) For J = 2 To UBound(rng, 2) Step 2 If rng(I, J) > 0 Then ReDim Preserve Cpt(2, k + 1) Cpt(0, k) = rng(I, 1) Cpt(1, k) = rng(I, J) k = k + 1 End If Next J Next I If k > 0 Then desWS.Range("C15:D" & Rows.Count).ClearContents desWS.Cells(15, 3).Resize(k, 2).Value = Application.Transpose(Cpt) 'اظافة الجدول loc = desWS.Range("C14:D" & desWS.[D65000].End(xlUp).Row).Address If desWS.ListObjects.Count <> 0 Then Exit Sub desWS.Cells(14, 3).Resize(, 2).Value = Array("Part", "INDEX") desWS.ListObjects.Add(xlSrcRange, desWS.Range(loc), , xlYes).Name = _ "Table1" End If Application.ScreenUpdating = True End Sub

ما فهمت منك لحد الساعة هو انك تريد فلترة ونسخ الصفوف مع الارتباط من ورقة Data الى الورقة النشطة تلقائيا بشرط وجود اسم الورقة في الخلية G2 ادا كان هدا هو طلبك ضع اولا الصيغة التالية في الخلية G2 على جميع الاوراق المرغوب نسخ البيانات عليها للتاكد من مطابقة الاسم يمكنك حدفها بعد دالك =MID(@CELL("filename";A1);FIND("]";@CELL("filename";A1))+1;31) وفي حدث Private Sub Worksheet_Activate ضع الكود التالي Private Sub Worksheet_Activate() Dim lRow2 As Long Set WS = Sheets("data"): Set dest = ActiveSheet If WS.AutoFilterMode Then WS.AutoFilterMode = False lRow2 = WS.Range("A" & Rows.Count).End(xlUp).Row Application.ScreenUpdating = False On Error Resume Next If dest.[G2].Value = dest.Name Then With WS.Range("A2:E" & lRow2) .AutoFilter Field:=5, Criteria1:=dest.[G2].Value Set Rng = WS.Range("A2:E" & lRow2).SpecialCells(xlCellTypeVisible) If Rng.Cells.Count > 1 Then With dest.Range("A2:F" & Rows.Count) .ClearContents: .Interior.ColorIndex = 0: .Borders.LineStyle = xlNone End With Rng.Copy dest.Range("A1") End If .AutoFilter End With End If On Error GoTo 0 End Sub TEST V2.xlsm