محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي الكريم Option Explicit Sub Découpe_45() Dim WS As Worksheet, WS2 As Worksheet Dim i As Long, j As Long, k As Long, x As Long Dim Cpt As Long, r As Long, headers As Range Set WS = ThisWorkbook.Sheets("ورقة1"): Set WS2 = ThisWorkbook.Sheets("ورقة3") Application.ScreenUpdating = False With WS2.Range("A4:F" & WS2.Rows.Count) .Cells.ClearFormats: .Cells.ClearContents End With j = 5: Cpt = 45: Set headers = WS.[A4:F4] k = WS.Range("A:F").Find("*", SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row For i = j To k Step Cpt If i = j Then headers.Copy Destination:=WS2.[A4] WS.Range("A" & i & ":F" & i + Cpt - 1).Copy Destination:=WS2.Range("A" & j) Else x = WS2.Range("A:F").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 7 headers.Copy Destination:=WS2.Range("A" & x) WS.Range("A" & i & ":F" & i + Cpt - 1).Copy Destination:=WS2.Range("A" & x + 1) End If Next i For r = 1 To 6 WS2.Cells.EntireRow.AutoFit WS2.Columns(r).ColumnWidth = WS.Columns(r).ColumnWidth Application.ErrorCheckingOptions.NumberAsText = False Next Application.ScreenUpdating = True End Sub جدول 2024.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا الحل ربما يناسبك Sub CopyRanges() Dim i As Long, a As Long, lr As Long Dim OneRng As Variant, arr As Variant, Irow As Long, C As Long Dim oldData() As Variant, newData() As Variant Dim xlnCalcMethod As XlCalculation Dim WS As Worksheet: Set WS = Sheets("نتيجةت4") Dim f As Worksheet: Set f = Sheets("نتيجة تقييم41") Irow = f.Cells.SpecialCells(xlCellTypeLastCell).Row oldData = Array("غ", "ازرق", "اخضر", "اصفر", "احمر") newData = Array("لم يتقن المعارف", "يفوق التوقعات", "امتلك المعارف والمهارات", "يحتاج لبعض الدعم", "لم يتقن المعارف") a = WS.Columns("E:AE").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row With Application xlnCalcMethod = .Calculation .Calculation = xlCalculationManual .EnableEvents = False .ScreenUpdating = False f.Range("E11:R" & f.Rows.Count).ClearContents OneRng = Array("F13:F" & a, "H13:H" & a, "J13:J" & a, "l13:l" & a, "N13:N" & a, "P13:P" & a, _ "R13:R" & a, "U13:U" & a, "W13:W" & a, "Y13:Y" & a, "AA13:AA" & a, "AC13:AC" & a, "AE13:AE" & a) arr = Array("E11", "F11", "G11", "H11", "I11", "J11", "K11", "L11", "M11", "N11", "O11", "P11", "Q11") For i = 0 To UBound(OneRng) WS.Range(OneRng(i)).Copy f.Range(arr(i)).PasteSpecial xlPasteValues Application.CutCopyMode = False Next lr = f.Columns("E:Q").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set Rng = f.Range("E11:Q" & lr) For C = LBound(oldData) To UBound(oldData) Rng.Replace oldData(C), newData(C), xlWhole, , , , False, False Next With f.Range("R11:R" & lr) .Formula = "=IF(" & WS.Name & "!F13="""",""""," & WS.Name & "!AF13)" .Value = .Value End With .Calculation = xlnCalcMethod .EnableEvents = True .ScreenUpdating = True End With End Sub تحويل الى كود V2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Private Sub CommandButton1_Click() Sum = Evaluate("=SUMIFS(F3:F100000,B3:B100000,"">=""&I2,B3:B100000,""<=""&j2)") Me.TextBox1.Value = Format(Sum, "#,##0.0") End Sub sumif.xlsm

لديك اخطاء في تحديد اسماء الخلايا كما في الصورة المرفقة تم تعديل الكود ليسهل التعامل معه Private Sub CommandButton2_Click() 'بحث Dim WS As Worksheet, F As Worksheet Dim Irow As Long, Clé As String, i As Long Set WS = Sheets("Sheet2"): Set F = Sheets("Sheet1"): Clé = F.[E3] Application.ScreenUpdating = False If Clé = Empty Then: MsgBox "برجاء إدخال اسم للبحث عن بياناته", vbCritical, "فلاح": Exit Sub Irow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row Set rng = WS.Range("B3:B" & Irow).Find(Clé, LookIn:=xlValues, _ lookat:=xlWhole, SearchDirection:=xlPrevious) If rng Is Nothing Then: MsgBox " الاسم غير موجود", vbExclamation, Clé: Exit Sub For i = 3 To Irow If WS.Cells(i, 2) = Clé Then ' Colmun (D) F.[D5] = WS.Cells(i, "B") F.[D7] = WS.Cells(i, "C"): F.[D9] = WS.Cells(i, "D"): F.[D11] = WS.Cells(i, "E") F.[D13] = WS.Cells(i, "F"): F.[D15] = WS.Cells(i, "G"): F.[D17] = WS.Cells(i, "H") F.[D19] = WS.Cells(i, "I"): F.[D21] = WS.Cells(i, "J"): F.[D23] = WS.Cells(i, "K") ' Colmun (G) F.[G7] = WS.Cells(i, "L"): F.[G9] = WS.Cells(i, "M"): F.[G11] = WS.Cells(i, "N") F.[G13] = WS.Cells(i, "O"): F.[G15] = WS.Cells(i, "P"): F.[G17] = WS.Cells(i, "Q") F.[G19] = WS.Cells(i, "R"): F.[G21] = WS.Cells(i, "S"): F.[G23] = WS.Cells(i, "T") ' Colmun (J) F.[J7] = WS.Cells(i, "U") F.[J9] = WS.Cells(i, "V"): F.[J11] = WS.Cells(i, "W") F.[J13] = WS.Cells(i, "X"): F.[J15] = WS.Cells(i, "Y") End If Next Application.ScreenUpdating = True End Sub مع تعديل كود الترحيل بالشكل التالي Private Sub CommandButton1_Click() ' اظافة Dim WS As Worksheet: Dim F As Worksheet Set WS = Sheets("Sheet1"): Set F = Sheets("Sheet2") Application.ScreenUpdating = False F.Range("B" & F.Rows.Count).End(xlUp).Offset(1).Resize(, _ 24).Value = Application.Index(WS.Range _ ("D5,D7,D9,D11,D13,D15,D17,D19,D21,D23,G7,G9,G11,G13,G15,G17,G19,G21,G23,J7,J9,J11,J13,J15"), _ 1, 1, Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, _ 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26)) With F.Range("A3:A" & F.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-2") End With Lr = F.Range("A65500").End(xlUp).Row b = F.Cells(2, F.Columns.Count).End(xlToLeft).Column F.Range(F.Cells(3, 1), F.Cells(Lr, b)).Borders.Weight = xlThin ' افراغ CommandButton4_Click Application.ScreenUpdating = True MsgBox "تم اضافة البيانات بنجاح" End Sub 123 (1).xlsm

هدا ملف مغاير اخي الكريم على العموم تفضل هده الاكواد الخاصة بك بعد تعديلها Private Sub CommandButton2_Click() 'بحث Dim WS As Worksheet, F As Worksheet, J As Long Dim rng As Range, LastRow As Long, Clé As String Set WS = Sheets("Sheet1"): Set F = Sheets("Sheet2"): Clé = WS.[E3] Application.ScreenUpdating = False If Clé = Empty Then: MsgBox "برجاء إدخال اسم للبحث عن بياناته", vbCritical, "فلاح": Exit Sub LastRow = F.Cells(F.Rows.Count, "B").End(xlUp).Row Set rng = F.Range("B3:B" & LastRow).Find(Clé, LookIn:=xlValues, _ lookat:=xlWhole, SearchDirection:=xlPrevious) If rng Is Nothing Then MsgBox " الاسم غير موجود", vbExclamation, Clé Else J = rng.Row WS.[D5].Value = F.Cells(J, 2).Value: WS.[D7].Value = F.Cells(J, 3).Value WS.[D9].Value = F.Cells(J, 4).Value: WS.[D11].Value = F.Cells(J, 5).Value WS.[D13].Value = F.Cells(J, 6).Value: WS.[D15].Value = F.Cells(J, 7).Value WS.[D17].Value = F.Cells(J, 8).Value: WS.[D19].Value = F.Cells(J, 9).Value WS.[D21].Value = F.Cells(J, 10).Value: WS.[D23].Value = F.Cells(J, 11).Value WS.[G7].Value = F.Cells(J, 12).Value: WS.[G9].Value = F.Cells(J, 13).Value WS.[G11].Value = F.Cells(J, 14).Value: WS.[G13].Value = F.Cells(J, 15).Value WS.[G15].Value = F.Cells(J, 16).Value: WS.[G17].Value = F.Cells(J, 17).Value WS.[G19].Value = F.Cells(J, 18).Value: WS.[G21].Value = F.Cells(J, 19).Value WS.[G23].Value = F.Cells(J, 20).Value Application.ScreenUpdating = True End If End Sub اما بالنسبة لكود التعديل يمكنك اتمامه بنفس الطريقة Private Sub CommandButton5_Click() 'تعديل Dim WS As Worksheet, WS2 As Worksheet Dim LastRow As Long, i As Long Set WS = Sheets("Sheet2"): Set WS2 = Sheets("Sheet1") LastRow = WS.Cells(WS.Rows.Count, 2).End(xlUp).Row For i = 3 To LastRow If WS.Range("B" & i).Value = WS2.[E3] Then WS.Range("B" & i) = WS2.Range("D5") WS.Range("C" & i) = WS2.Range("D7") WS.Range("D" & i) = WS2.Range("D9") WS.Range("E" & i) = WS2.Range("D11") WS.Range("F" & i) = WS2.Range("D13") 'اتمم الكود '''''''''''''''''''' '''''''''''''''''''' MsgBox "تم تعديل البيانات بنجاح" End If Next i Application.ScreenUpdating = True End Sub 123.xlsm

جرب هل هدا ما تقصده Sub TEST() Dim WS As Worksheet: Dim F As Worksheet Set WS = Sheets("ورقة2"): Set F = Sheets("ورقة3") Application.ScreenUpdating = False F.Range("B" & F.Rows.Count).End(xlUp).Offset(1).Resize(, _ 26).Value = Application.Index(WS.Range _ ("D5,C7,C9,C11,D13,E15,D17,D19,D21,J7,J9,J11,J13,J15,J17,I19,K19,J21,O7,O9,O11,N13,N15,N17,O19,O21"), _ 1, 1, Array(2, 3, 1, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, _ 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26)) With F.Range("A4:A" & F.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-3") End With Application.ScreenUpdating = True MsgBox "تم ترحيل البيانات بنجاح" End Sub New ورقة عمل Microsoft Excel 2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا =IFS(A1="","",A1=0,"لا توجد بضاعة",A1<=999,99,"المخزون على وشك النفاد",A1>=1000,"المخزون متوفر") 'OR =IF(A1=0,"لا توجد بضاعة",IF(A1<=999,99,"المخزون على وشك النفاد",IF(A1>=1000,"المخزون متوفر"))) example.xlsx

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

في هده الحالة سيتم الاستغناء عن عناصر label وتعويضها بالصور ضع الكود التالي في Module Option Explicit Public IM() As New Classe1 Sub USF() Dim c As Control, n% With UserForm7 For Each c In .Controls If TypeName(c) = "Image" Then ReDim Preserve IM(n) Set IM(n).IM = c n = n + 1 End If Next End With End Sub وفي Classe Module Option Explicit Public WithEvents IM As MSForms.Image Private Sub IM_Click() Dim c As Control For Each c In IM.Parent.Parent.Controls If TypeName(c) = "Frame" Then c.BackColor = RGB(255, 255, 255) Next 'Yellow IM.Parent.BackColor = RGB(255, 255, 0) 'Red..........= RGB(255,0,0) End Sub مع تعديل الاكواد التالية بعد حدف عناصر label Private Sub UserForm_Initialize() For c = 1 To 4 Me("Image" & c).Visible = False Next End Sub '*********************** Private Sub UserForm_Activate() Call USF With Me .startUpPosition = 3 .Width = Application.Width .Height = Application.Height .Left = 0 .Top = 0 End With End Sub ملاحظة Private Sub Workbook_Open() 'تم تعطيل الكود ليتمكن الجميع من الاستفادة Application.DisplayAlerts = False Application.Visible = False 'If Date >= DateValue("15/06/2024") Or Sheets("names").Range("zz1") = "eta" Then 'Sheets("names").Range("zz1") = "eta" 'MsgBox "call me 00201113135517" 'ThisWorkbook.Save 'Application.Quit 'Else UserForm7.Show 'End If End Sub 2.xlsb

هل تقصد انك قمت باستبدال عناصر label بالصور ارفق ملفك مع الصور المرغوب اظافتها مع تحديد مكان تواجدها لنتمكن من تعديل الكود بما يتناسب مع الوضع الحالي

For c = 1 To 2 For j = 3 To 4 Me("Label" & c).Left = (Me.Width / 1.5) - (Me("Label" & c).Width / 1.5) Me("Label" & j).Left = (Me.Width / 2) - (Me("Label" & j).Width / 1.6) Next Next يمكنك تعديله بالشكل التالي مع التلاعب قليلا بالمكان الاصلي لعناصر label على اليوزرفورم 1.rar

تفضل اخي Private Sub UserForm_Activate() With Me .startUpPosition = 3 .Width = Application.Width .Height = Application.Height .Left = 0 .Top = 0 End With For c = 1 To 4 Me("Label" & c).Left = (Me.Width / 1.8) - (Me("Label" & c).Width / 2.4) Next End Sub 1.rar

وعليكم السلام ورحمة الله تعالى وبركاته يصعب التعامل مع الكود بدون ارفاق الملف لاكن حاول تجربة شيء كهدا Private Sub UserForm_Activate() Me.Label1.Left = (Me.Width / 2) - (Me.Label1.Width / 2) Me.Label2.Left = (Me.Width / 2) - (Me.Label2.Width / 2) Me.Label3.Left = (Me.Width / 2) - (Me.Label3.Width / 2) Me.Label4.Left = (Me.Width / 2) - (Me.Label4.Width / 2) End Sub 'OR Private Sub UserForm_Activate() For c = 1 To 4 Me("Label" & c).Left = (Me.Width / 2) - (Me("Label" & c).Width / 2) Next End Sub test.xlsm

جرب احدى المعادلات التالية 1) =IFERROR(INDEX($C$5:$C$10000;MATCH(2;1/($C$5:$C$10000<>"")));"") 2) =IFERROR(LOOKUP(2;1/($C$5:$C$1000<>"");$C$5:$C$1000);"") 3)قيمة رقمية =IFERROR(LOOKUP(9E+307;C:C);"") mdrrsah.xlsx

ولك بالمثل اخي لقد لاحظت ان الاعمدة الاخيرة تتضمن روابط المقاطع على اليوتيوب والفايس اليك تحديث الكود لتتمكن من نسخ Hyperlinks المواقع والانتقال اليها عبر الوورد Public Property Get n() As Worksheet: Set n = Worksheets("WordCopy") End Property Sub Copy_Transfer_WORD1() Dim arr() As String: Dim cnt() As String Dim lastRow As Long: Dim rngA As Variant: Dim rngB As Variant Dim OneRng As Range: Dim tmp As Range: Dim Ary As Variant Dim i As Long: Dim r As Integer: Dim x As Long: Dim j As Range Application.DisplayAlerts = False Application.ScreenUpdating = False Set WS = Worksheets("Sheet1") n.Visible = xlSheetVisible: n.Cells.UnMerge n.Range("A1:J" & n.Rows.Count).Clear lige = 7 lastRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row cnt() = Split("I-H,J-I", ",") rngA = Array(1, 3, 4, 5, 6, 7, 8) rngB = Array(1, 2, 3, 4, 5, 6, 7) For i = 0 To UBound(rngA) With WS Set OneRng = .Range(.Cells(lige, _ rngA(i)), .Cells(lastRow, rngA(i))).SpecialCells(xlCellTypeVisible) OneRng.Copy n.Cells(1, _ rngB(i)).PasteSpecial Paste:=xlPasteValuesAndNumberFormats End With Next i For r = 0 To UBound(cnt): arr = Split(cnt(r), "-") WS.Range(arr(0) & "8:" & arr(0) & lastRow).Copy Destination:=n.Cells(2, arr(1)) Next r lr = n.Cells(n.Rows.Count, "A").End(xlUp).Row Set tmp = n.Range("A1:J" & n.Rows.Count) Set a = n.Rows(1): Set b = n.Rows(2): Set d = n.[A1:I1]: Set E = n.Range("A3:I" & lr) a.RowHeight = 75: a.Font.Bold = True: b.RowHeight = 40: b.Font.Bold = True: b.Font.Size = 14: d.Font.Size = 24 d.Merge: d.Interior.Color = RGB(192, 192, 192): n.[A2:I2].Interior.Color = RGB(215, 238, 247) With E .Font.Name = "AdvertisingBold": .Font.Size = 13 .WrapText = True: .MergeCells = False End With F = n.Cells(2, n.Columns.Count).End(xlToLeft).Column n.Range(n.Cells(2, 1), n.Cells(lr, F)).Borders.Weight = xlThin Ary = Array(5, 15, 38, 38, 38, 15, 15, 15, 15) For x = 0 To UBound(Ary) n.Columns(x + 1).ColumnWidth = Ary(x) Next x Set Irow = n.Range("A3", n.Cells(n.Rows.Count, "A").End(xlUp)) For Each j In Irow.Rows If j.RowHeight < 20 Then: j.RowHeight = 35: Else j.EntireRow.AutoFit Next With tmp .EntireColumn.HorizontalAlignment = xlCenter .EntireColumn.VerticalAlignment = xlCenter End With With n.Range("A3:A" & n.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-2") End With WS.Activate: ExcelToWordSheet1 n.Visible = xlSheetVeryHidden Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub 2024 final V3.xlsm

تفضل اخي الكريم 2024 final V2.xlsm

ضع الكود التالي في حدث ورقة Sheet1 سيتم تحديث التسلسل عند اظافة صف او حدفه . وعند كتابة تاريخ جديد في عمود C Private Sub Worksheet_Change(ByVal Target As Range) Dim I As Integer, lastRow As Long Dim WS As Worksheet: Set WS = Sheets("Sheet1") Application.EnableEvents = False Application.ScreenUpdating = False With Target Select Case .Column Case 1, 3 If .Row > 8 Then WS.Range("A9:A" & WS.Rows.Count).ClearContents lastRow = WS.Range("C" & WS.Rows.Count).End(xlUp).Row For I = 9 To lastRow WS.Range("A" & I).Value = Val(WS.Range("A8")) + I - 8 Next I End If End Select End With Application.ScreenUpdating = True Application.EnableEvents = True End Sub اما بخصوص عكس التاريخ ليس له علاقة بالكود المشكلة عندك في تنسيق الملف ان شاء الله اول ما اتفرغ ساحاول تعديل طريقة نسخ البيانات لتتناسب مع طلبك ادا لم يسبقني احد الاخوة في دالك 2024 final DATE.xlsm

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

في حالة الرغبة باستخدام الكود الخاص بك يكفي تعديله فقط على الشكل التالي Sub PDF() Dim Path As String Path = Label2.Caption 'Code......................... ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _ Path & "ملف رواتب الموظفين\" & fName, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False End Sub

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي جرب هدا Private Sub CommandButton1_Click() Dim WS As Worksheet: Set WS = Sheet3 Dim FileName As String, strDirname As String, Patch As String, strDefpath As String strDirname = Me.TextBox1.Text FileName = WS.[B8] strDefpath = Label2.Caption lr = WS.Range("B" & WS.Rows.Count).End(xlUp).Row WS.PageSetup.PrintArea = "A1:D" & lr + 5 On Error Resume Next If FileName = "" Then MsgBox "يرجى اظافة اسم الملف": Exit Sub If Not Right(strDefpath, 1) = "\" Then strDefpath = strDefpath & "\" If Not Right(FileName, 4) = ".Pdf" Then FileName = FileName & ".Pdf" If Dir(strDefpath & strDirname, vbDirectory) = "" Then MkDir strDefpath & strDirname Patch = strDefpath & strDirname & "\" & FileName WS.ExportAsFixedFormat Type:=xlTypePDF, FileName:=Patch End Sub ملف V2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته المفروض اخي @Alaa Ammar New ورقة الاشطة خاصة بفلترة البيانات بين تاريخين يتم تحديدهم مسبقا في الخلية D2 و F2 بمعنى انت من تحدد البيانات الظاهرة عليها .في حالة الرغبة بجلب جميع البيانات يمكنك فقط تحديد اول واخر تاريخ لديك على Sheet1 يمكنك اظافة الكود التالي في حدث Sheet1 ليتم تحديث التسلسل تلقائيا . Private Sub Worksheet_Change(ByVal Target As Range) Dim sht As Worksheet: Set sht = Sheets("Sheet1") If Target.Column = 1 Then Application.ScreenUpdating = False Application.EnableEvents = False sht.Range("A9:A" & sht.Rows.Count).ClearContents sht.[A9].Value = 1 With sht.Range("A9:A" & sht.Cells(sht.Rows.Count, "C").End(xlUp).Row) .Formula = "=Row() - 8" .Value = .Value End With Application.EnableEvents = True Application.ScreenUpdating = True End If End Sub Dim desWS As Worksheet: Set desWS = Sheets("Sheet1") Dim dest As Worksheet: Set dest = printing Application.ScreenUpdating = False If Sheets("Sheet1").TextBox1.Text = "" Then: MsgBox "يرجى اظافة معيار الفلترة": Exit Sub rng = Application.WorksheetFunction.Subtotal(3, desWS.Range("L9:L10000")) If rng = 0 Then: MsgBox "لا توجد بيانات للحفظ", _ vbInformation, "تم إلغاء الإجراء": Exit Sub dest.Visible = xlSheetVisible Set a = desWS.Range("A7", desWS.Range("A" & desWS.Rows.Count).End(xlUp)) For r = 1 To 12 Set a = Union(a, Intersect(a.EntireRow, a.Columns(r))) Next r Msg = MsgBox("؟" & " " & "PDF " & ":" & " تصدير التقرير بصيغة", vbYesNo, dest.Name) If Msg <> vbYes Then Exit Sub dest.Range("A2:L" & dest.Rows.Count).Clear a.Copy Destination:=dest.Range("A6") dest.Range("a8").Value = 1 With dest.Range("a8:a" & dest.Cells(dest.Rows.Count, "B").End(xlUp).Row) .Formula = "=Row() - 7" .Value = .Value End With 'حفظ PDF Save_As_PDF2 On Error Resume Next desWS.AutoFilter = False Sheets("Sheet1").TextBox1.Text = "" Application.ScreenUpdating = True 2024 final.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي ضع الكود التالي في Module Function arr(a, b) maxtab1 = UBound(a) Dim tmp(): ReDim tmp(1 To UBound(a) + UBound(b), 1 To UBound(a, 2)) For i = LBound(a) To UBound(a) For c = 1 To UBound(a, 2): tmp(i, c) = a(i, c): Next Next i For i = 1 To UBound(b) For c = 1 To UBound(b, 2): tmp(maxtab1 + i, c) = b(i, c): Next Next i arr = tmp End Function وفي داخل اليوزرفورم Dim rng(), Cnt, Width, OneRng, ColVisu '09/06/2024 by:MOHAMEED HICHAM www.officena.net "منتدى الاكسيل" ' Private Sub UserForm_Initialize() Dim Cpt, F Cpt = [Data]: F = [Data1]: rng = arr(Cpt, F) 'Merge table data For i = LBound(rng) To UBound(rng): rng(i, 2) = Format(rng(i, 2), "dd/mm/yyyy"): Next i OneRng = "Data" Width = Array(100, 80, 80, 160, 80, 60) ColVisu = Array(6, 5, 4, 3, 2, 1): Cnt = UBound(ColVisu) + 1 For c = 1 To Cnt tmp = Range(OneRng).Offset(-1).Item(1, c) Me("Label" & c).Caption = tmp: Me("Labtxt" & c).Caption = tmp Next txtClear Me.ListBox1.ColumnCount = Cnt Me.ListBox1.ColumnWidths = Join(Width, ";") Dim result(): n = 0 For i = 1 To UBound(rng) n = n + 1: ReDim Preserve result(1 To Cnt, 1 To n) c = 0 For Each k In ColVisu c = c + 1: result(c, n) = rng(i, k) Next k Next i If n > 0 Then Me.ListBox1.Column = result: Counter = ListBox1.ListCount Else Me.ListBox1.Clear End If End Sub '***************** Sub filterdata() Dim result(): n = 0 Dim Cpt1 As String, Cpt2 As String For i = 1 To UBound(rng) 'الاسم If TextBox1.Value = "" Then Cpt1 = rng(i, 3) Else Cpt1 = "*" & TextBox1.Value & "*" 'رقم المعاملة If TextBox2.Value = "" Then Cpt2 = rng(i, 6) Else Cpt2 = "*" & TextBox2.Value & "*" If LCase(rng(i, 3)) Like LCase(Cpt1) And LCase(rng(i, 6)) Like LCase(Cpt2) Then n = n + 1: ReDim Preserve result(1 To Cnt, 1 To n) c = 0 For Each r In ColVisu c = c + 1: result(c, n) = rng(i, r) Next r End If Next i If n > 0 Then Me.ListBox1.Column = result Counter = ListBox1.ListCount Else Me.ListBox1.Clear End If txtClear End Sub '*********************** Private Sub TextBox1_Change() Call filterdata End Sub Private Sub TextBox2_Change() Call filterdata End Sub Private Sub ListBox1_Click() For i = 1 To Cnt Me("txt" & i) = Me.ListBox1.Column(i - 1) Next i End Sub '********************* Private Sub transfert_Click() Set WS = Sheets("Sheet1") WS.Cells.ClearContents n = ListBox1.ListCount: result = Me.ListBox1.List WS.[A2].Resize(n, 6) = Application.Index(result, _ Evaluate("Row(1:" & n & ")"), ColVisu) c = 0 For c = 1 To Cnt WS.Cells(1, c) = Range(OneRng).Offset(-1).Item(1, c) Next Me.TextBox1 = "": Me.TextBox2 = "" MsgBox "تم ترحيل البيانات بنجاح", Exclamation, "admin" End Sub '************************* Sub txtClear() For k = 1 To Cnt Me("txt" & k) = "" Next k End Sub كشف المعاملات المؤرشفة.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته اظن ان الصيغة الصحيحة للسؤال هي حساب عدد الاختلافات جرب وضع احدى المعادلات التالية في الخلية E2 =SUM(IFERROR(1/COUNTIFS($D$5:$D$200;$D$5:$D$200;$F$5:$F$200;D2);0)) OR =IFERROR(SUM(IF(D2=$F$5:$F$200;1/(COUNTIFS($F$5:$F$200;D2;$D$5:$D$200;$D$5:$D$200));0));"") التكرار2.xlsx

حساب السن أول 10.xlsx

ولك بالمثل اخي @أبو قاسم يسعدنا اننا استطعنا مساعدتك