محمد هشام.

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

من الافضل جعل قيمة القائمة المنسدلة دور ثان فقط بدون له او لها واستخدام الكود التالي Sub Filter_and_copy_with_condition() Dim d, j Dim Search As Range, clé As String, IRow As Long Dim WS As Worksheet: Set WS = Worksheets("control4") Dim F As Worksheet: Set F = Worksheets("saad") d = 9: j = 16: clé = "*" & F.[k1] IRow = WS.Range("U:U").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row With Application .Calculation = xlManual .ScreenUpdating = False If Len([k1].Value) = 0 Then: Exit Sub Set Search = WS.Range("U16:U" & IRow).Find(clé, LookIn:=xlValues, lookat:=xlWhole) If Search Is Nothing Then MsgBox clé & " " & "غير موجود", vbExclamation, "Admin": Exit Sub F.Range("C10:O" & Rows.Count).ClearContents Do Until IsEmpty(WS.Range("U" & j)) If WS.Range("U" & j) Like clé Then d = d + 1 F.Cells(d, 3).Value = WS.Cells(j, 3).Value F.Cells(d, 5).Value = WS.Cells(j, 5).Value F.Cells(d, 6).Value = WS.Cells(j, 6).Value F.Cells(d, 8).Value = WS.Cells(j, 10).Value F.Cells(d, 10).Value = WS.Cells(j, 12).Value F.Cells(d, 11).Value = WS.Cells(j, 13).Value F.Cells(d, 12).Value = WS.Cells(j, 16).Value F.Cells(d, 13).Value = WS.Cells(j, 17).Value F.Cells(d, 14).Value = WS.Cells(j, 18).Value F.Cells(d, 15).Value = WS.Cells(j, 21).Value End If j = j + 1 Loop .Calculation = xlAutomatic .ScreenUpdating = True End With End Sub مصطفي V3.xlsb

تفضل ووافينا بالنتيجة Sub Filter_and_copy_with_condition() Dim Rng As Range, Search As Range Dim Col As Variant, a As Variant, MyRng As Variant, clé As Variant Dim i As Long, F As Long, Cpt As Long, Lastrow As Long, Irow As Long, ColStar As Long Dim WS As Worksheet: Set WS = Worksheets("control4") Dim desWS As Worksheet: Set desWS = Worksheets("saad") clé = desWS.[k1]: ColStar = 10 'نطاق البيانات Lastrow = WS.Range("U:U").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set Rng = WS.Range("C16:U" & Lastrow) Col = Rng.Value2 If Len([k1].Value) = 0 Then: Exit Sub With desWS Set Search = WS.Range("U16:U" & Lastrow).Find(clé, LookIn:=xlValues, lookat:=xlWhole) If Search Is Nothing Then MsgBox clé & " " & "غير موجود", vbExclamation, "Admin": Exit Sub Application.ScreenUpdating = False ' تخزين البيانات القديمة Irow = desWS.Columns("C:AT").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row For Cpt = ColStar To Irow MyRng = desWS.Range("P10:AT" & Cpt).Value Next ' افراغ البيانات السابقة desWS.Range("C10:O" & Cpt).ClearContents ReDim a(1 To UBound(Col), 1 To UBound(Col, 2)) End With For i = 1 To UBound(Col) ' عند تحقق الشرط If Col(i, 19) = clé Then F = F + 1 a(F, 1) = Col(i, 1): a(F, 3) = Col(i, 3): a(F, 4) = Col(i, 4) a(F, 6) = Col(i, 8): a(F, 8) = Col(i, 10): a(F, 9) = Col(i, 11) a(F, 10) = Col(i, 14): a(F, 11) = Col(i, 15): a(F, 12) = Col(i, 16): a(F, 13) = Col(i, 19) End If Next i [C10].Resize(F, UBound(a, 2)).Value2 = a For Cpt = ColStar To Irow desWS.Range("P10:AT" & Cpt).Value = MyRng Next Application.ScreenUpdating = True End Sub وفي حدث ورقة saad ضع الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Not Intersect(Target, Range("k1")) Is Nothing Then Call Filter_and_copy_with_condition End If End Sub مصطفي V2.xlsb

حل اخر مع اليوم الافتراضي لبداية الاسبوع بالنسبة لي . Sub GroupWeek_2() Dim wb As Workbook: Set wb = ThisWorkbook Dim ws As Worksheet: Set ws = Sheet1 Dim desWS As Worksheet: Set desWS = Sheet2 desWS.Cells.ClearContents: Cells.Interior.ColorIndex = xlNone ws.Range("A1:B1", ws.Range("a" & Rows.Count).End(xlUp)).Copy desWS.Range("A1") GroupByWeek desWS, "a2", "a", "اسبوع " End Sub Sub GroupByWeek( _ ByVal desWS As Worksheet, _ ByVal Clé As String, _ Optional ByVal GroupColumn As Variant = "a", _ Optional ByVal GroupBaseName As String = "اسبوع ") Dim f As Range, IRow As Long, lr& Dim Rng As String Dim minDate As Date, maxDate On Error Resume Next IRow = desWS.Columns("A:B").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 1 minDate = Application.WorksheetFunction.Min(desWS.Range("A2:A" & IRow)) maxDate = Application.WorksheetFunction.Max(desWS.Range("A2:A" & IRow)) With Range("a2:a" & IRow) Set f = .Find(What:="اسبوع" & "*", lookat:=xlWhole, LookIn:=xlValues, MatchCase:=False) If Not f Is Nothing Then Exit Sub End If End With Dim fCell As Range: Set fCell = desWS.Range(Clé) Dim lCell As Range Set lCell = fCell.Resize(desWS.Rows.Count - fCell.Row + 1) _ .Find("*", , xlFormulas, , , xlPrevious) If lCell Is Nothing Then Exit Sub Dim rCount As Long: rCount = lCell.Row - fCell.Row + 1 Dim crg As Range: Set crg = fCell.Resize(rCount) Dim Data As Variant If rCount = 1 Then ReDim Data(1 To 1, 1 To 1): Data = crg.Value Else Data = crg.Value End If ReDim Preserve Data(1 To rCount, 1 To 2) Dim CurrValue As Variant Dim CurrDate As Date Dim OldWeek As Long Dim NewWeek As Long Dim sr As Long Dim Cpt As Long For sr = 1 To rCount CurrValue = Data(sr, 1) If IsDate(CurrValue) Then NewWeek = Application.WeekNum(CurrValue) If NewWeek <> OldWeek Then Cpt = Cpt + 1 Set Data(Cpt, 1) = crg.Cells(sr) Data(Cpt, 2) = NewWeek OldWeek = NewWeek End If End If Next sr If Cpt = 0 Then Exit Sub For Cpt = Cpt To 1 Step -1 With Data(Cpt, 1) .EntireRow.Insert xlShiftDown .Offset(-1).EntireRow.Columns(GroupColumn).Value _ = GroupBaseName & Data(Cpt, 2) End With Next Cpt Dim ar As Range For Each ar In desWS.Range("b2:b" & desWS.Range("b" & Rows.Count).End(xlUp).Row + 1).SpecialCells(xlCellTypeConstants).Areas ar.Offset(-1).Resize(1).Value = WorksheetFunction.Sum(ar) Next lr = desWS.Columns("A:b").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 1 With desWS.Range("a2:a" & lr) Set f = .Find(What:="اسبوع" & "*", lookat:=xlWhole, LookIn:=xlValues, MatchCase:=False) If Not f Is Nothing Then Rng = f.Address Do desWS.Range("a:b").Rows(f.Row).Interior.ColorIndex = 8 f.Interior.ColorIndex = 45 Set f = .FindNext(f) ' Loop While f.Address <> Rng End If End With Application.ScreenUpdating = True MsgBox "من :" & " " & Format(minDate, "dd/mm/yyyy") & vbLf & vbLf & "إلى :" & " " & Format(maxDate, "dd/mm/yyyy"), vbInformation End Sub مجموع كل أسبوع V2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته مجرد فكرة ربما تناسبك Public Sub Split_Sheet_By_Weekly_Date_Ranges() Dim desWS As Worksheet, WS As Worksheet: Set WS = Sheet1 Dim lr As Long, minDate As Date, maxDate Dim WeekStar As Date, desWSName As String With Application .ScreenUpdating = False .DisplayAlerts = False For Each SH In Worksheets If SH.Name <> WS.Name Then Application.DisplayAlerts = False SH.Delete End If Next With WS lr = .Cells(.Rows.Count, "A").End(xlUp).Row minDate = Application.WorksheetFunction.Min(.Range("A2:A" & lr)) maxDate = Application.WorksheetFunction.Max(.Range("A2:A" & lr)) End With WeekStar = Date_Prev_Saturday(minDate) While WeekStar <= maxDate desWSName = Format(WeekStar, "dd-mm") & " To " & Format(WeekStar + 6, "dd-mm") With ActiveWorkbook Set desWS = Nothing On Error Resume Next Set desWS = .Worksheets(desWSName) On Error GoTo 0 If desWS Is Nothing Then Set desWS = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count)) desWS.Name = desWSName desWS.DisplayRightToLeft = True End If End With desWS.[A1:B1].Value = Array(WS.[A1].Value) desWS.[A2:B2].Value = Array(">=" & CLng(WeekStar), "<=" & CLng(WeekStar) + 6) WS.Range("A1:B" & lr).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=desWS.[A1:B2], CopyToRange:=desWS.[A4], Unique:=False desWS.Columns("A:B").AutoFit IRow = desWS.Cells(Rows.Count, "a").End(xlUp).Row + 1 With desWS.Range("A2:B" & IRow) .Cells(IRow - 1, "b").Formula = "=SUM(b5:b" & IRow - 1 & ")": .Cells(IRow - 1, "a").Value = "المجموع" .HorizontalAlignment = xlCenter .Value = .Value With Range("A" & IRow & ":B" & IRow).Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With End With desWS.Rows("1:3").Delete Shift:=xlUp If desWS.[A3] = "" Then desWS.Delete WeekStar = WeekStar + 7 Wend WS.Activate DisplayAlerts = True .ScreenUpdating = True End With MsgBox "من :" & " " & Format(minDate, "dd/mm/yyyy") & vbLf & vbLf & "إلى :" & " " & Format(maxDate, "dd/mm/yyyy"), vbInformation End Sub 'Given a date, return the date of the preceding Saturday, or the date itself if it is a Saturday Private Function Date_Prev_Saturday(fromDate As Date) As Date Date_Prev_Saturday = fromDate - Weekday(fromDate) + vbSaturday + 7 * (vbSaturday > Weekday(fromDate)) End Function مجموع كل أسبوع على حدة.xlsm

تفضل اخي Sub SaveFile_Excel() Dim wb As Workbook, desWS As Worksheet Set wb = ThisWorkbook: Set desWS = wb.Sheets("الفاتورة ") Dim a(1 To 3) As String Dim shape As shape: Dim rng As Range 'اسم الملف a(1) = desWS.[D3].Value With Application .ScreenUpdating = False .DisplayAlerts = False On Error Resume Next 'اسم مجلد الحفظ قم بتعديله بما يناسبك a(2) = "Excel فواتير المبيعات" '***********'لحفظ الملف في نفس مسار المصنف الرئيسي********* ' a(3) = Application.ActiveWorkbook.Path & "\" & a(2) '*************لحفظ الملف في بارتيشن من اختيارك************* ' قم بتحديد اسم البارتيشن الخاصة بك a(3) = "D:\" & a(2) ' انشاء المجلد في حالة عدم العثور عليه If Dir(a(3), vbDirectory) = "" Then MkDir a(3) Cpt = Dir(a(3) & "\" & a(1) & "*") desWS.Copy Set rng = [B1:F22] With rng .Value = .Value: .Validation.Delete For Each shape In ActiveSheet.Shapes shape.Delete Next End With ' تسلسل اسم الملف F = 0 Do While Cpt <> "" F = F + 1 Cpt = Dir Loop '(Excel بصيغة)' ' حفظ الملف في المسار التالي Application.ActiveWorkbook.SaveAs Filename:=a(3) & "\" & a(1) & "_" & F + 1 & ".xlsx", FileFormat:=51 ' غلق المصنف ActiveWorkbook.Close DisplayAlerts = True .ScreenUpdating = True End With MsgBox "تم نسخ ملف " & " " & a(1) & " " & " بنجاح" & vbLf & vbLf & a(3) & _ "", vbInformation, "ملف رقم :" & " " & F + 1 End Sub لحفظ الملف بصيغة PDF قم بتعديل هدا السطر '(PDF بصيغة)' Application.ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=a(3) & "\" & a(1) & "_" & F + 1 حسابات احمد Excel & PDF.xlsm

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

تفضل اخي اليك حل اخر ربما هدا ما تقصده 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