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

نعم اخي المشكلة في طريقة البحث التي تستخدمها لهدا سنعتمد على طريقة متقدمة نوعا ما لتنفيد طلبك وتحديد الصف بدون الاعتماد على إسم او رقم الملف مع اظافة إمكانية البحث والفلترة بأي عمود Private Sub ListBox1_Click() Dim lastRow As Long: lastRow = f.Rows.Count f.Range("A7:A" & lastRow).Interior.ColorIndex = xlNone For i = 1 To OnRng Me("textbox" & i) = Me.ListBox1.Column(i - 1) Next i Me.N_ligne = Me.ListBox1.Column(i - 1) rng = Me.N_ligne + 6 If rng > 0 Then With f .Range(.Cells(rng, "C"), .Cells(rng, "N")).Select .Cells(rng, "A").Interior.Color = RGB(0, 0, 255) End With End If End Sub تعديل فورم V5 -.rar

وجدت الحل بحمدلله Private Sub CheckBox1_Click() Dim arr() As Variant Dim i As Long, j As Long, temp As Variant Dim sortColumn As Integer Dim sortOrder As Boolean ' نسخ البيانات من ListBox إلى المصفوفة ReDim arr(ListBox1.ListCount - 1, ListBox1.ColumnCount - 1) For i = 0 To ListBox1.ListCount - 1 For j = 0 To ListBox1.ColumnCount - 1 arr(i, j) = ListBox1.List(i, j) Next j Next i ' تحديد عمود الفرز بناءً على ComboBox sortColumn = ComboBox1.ListIndex ' تحديد اتجاه الفرز بناءً على CheckBox sortOrder = CheckBox1.Value ' الفرز باستخدام Bubble Sort For i = LBound(arr) To UBound(arr) - 1 For j = i + 1 To UBound(arr) If sortOrder Then ' ترتيب تنازلي If IsNumeric(arr(i, sortColumn)) Or IsNumeric(arr(j, sortColumn)) Then If CDbl(arr(i, sortColumn)) > CDbl(arr(j, sortColumn)) Then ' تبادل السجلين For k = LBound(arr, 2) To UBound(arr, 2) temp = arr(i, k) arr(i, k) = arr(j, k) arr(j, k) = temp Next k End If Else If UCase(arr(i, sortColumn)) > UCase(arr(j, sortColumn)) Then ' تبادل السجلين For k = LBound(arr, 2) To UBound(arr, 2) temp = arr(i, k) arr(i, k) = arr(j, k) arr(j, k) = temp Next k End If End If Else ' ترتيب تصاعدي If IsNumeric(arr(i, sortColumn)) Or IsNumeric(arr(j, sortColumn)) Then If CDbl(arr(i, sortColumn)) < CDbl(arr(j, sortColumn)) Then ' تبادل السجلين ' تبادل السجلين For k = LBound(arr, 2) To UBound(arr, 2) temp = arr(i, k) arr(i, k) = arr(j, k) arr(j, k) = temp Next k End If Else If UCase(arr(i, sortColumn)) < UCase(arr(j, sortColumn)) Then ' تبادل السجلين ' تبادل السجلين For k = LBound(arr, 2) To UBound(arr, 2) temp = arr(i, k) arr(i, k) = arr(j, k) arr(j, k) = temp Next k End If End If End If

وعليكم السلام ورحمة الله وبركاته لو ارفقت لنا ملفك لاختصرت الوقت او ارفقت الجملة التى بها خطأ لسهلت لنا الامر يدون ملف محاولات قد تصيب وقد تخطئ ريما السبب من جملة FILESEARCH والتي اعتقد انها غير متوافقة مع الاصدارات بعد 2003 ( غير متاكد منها) سنفترض ان الامر منها فيكون تعديل الكود كالتالى Private Sub FrstChnge(combo1 As ComboBox, combo2 As ComboBox) Dim val As String Dim Namey As String Dim fso As Object Dim folder As Object Dim file As Object combo2.Clear If combo1.Value = "" Then MsgBox "الرجاء اختيار شيت من القائمة", vbExclamation Exit Sub End If val = ThisWorkbook.Path & "\" & combo1.Value & "\Ser" Set fso = CreateObject("Scripting.FileSystemObject") If fso.FolderExists(val) Then Set folder = fso.GetFolder(val) For Each file In folder.Files If LCase(fso.GetExtensionName(file.Name)) = "xlsx" Then Namey = file.Name Namey = Left(Namey, Len(Namey) - 5) ' إزالة الامتداد .xlsx combo2.AddItem Namey End If Next file Else MsgBox "المجلد غير موجود: " & val, vbExclamation End If Set fso = Nothing Set folder = Nothing Set file = Nothing End Sub او جرب الكود التالى Private Sub FrstChnge(combo1 As ComboBox, combo2 As ComboBox) Dim val As String Dim filePath As String Dim fileName As String val = combo1.Value combo2.Clear If val = "" Then Exit Sub filePath = ThisWorkbook.Path & "\" & val & "\Ser\" fileName = Dir(filePath & "*.xls*") Do While fileName <> "" combo2.AddItem Left(fileName, Len(fileName) - 4) fileName = Dir Loop End Sub اذا لم بعمل ارفق ملفك وفقك الله

Option Explicit Sub test() Dim arr As Variant, i As Long, Irow As Long Dim dictA As Object, dictB As Object, dictC As Object, dictD As Object Dim n As Variant, a As Variant, b As Variant, c As Variant Dim WS As Worksheet: Set WS = Sheets("Sheet1") With WS Irow = .Columns("A:E").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If WorksheetFunction.CountA(.Range("A2:A" & Irow)) = 0 And _ WorksheetFunction.CountA(.Range("B2:B" & Irow)) = 0 Then MsgBox "لا توجد بيانات للمقارنة", vbExclamation Exit Sub End If 'Code ............. .................. Set dictC = CreateObject("Scripting.Dictionary") Set dictD = CreateObject("Scripting.Dictionary") For i = 2 To Irow If WS.Cells(i, 3).Value <> "" Then dictC(WS.Cells(i, 3).Value) = True If WS.Cells(i, 4).Value <> "" Then dictD(WS.Cells(i, 4).Value) = True Next i For i = 2 To Irow If WS.Cells(i, 1).Value <> "" Then If dictC.exists(WS.Cells(i, 1).Value) Or dictD.exists(WS.Cells(i, 1).Value) Then WS.Cells(i, 1).Interior.Color = RGB(255, 255, 0) End If End If If WS.Cells(i, 2).Value <> "" Then If dictC.exists(WS.Cells(i, 2).Value) Or dictD.exists(WS.Cells(i, 2).Value) Then WS.Cells(i, 2).Interior.Color = RGB(255, 165, 0) End If End If Next i Application.ScreenUpdating = True End Sub مقارنة 3.xlsb

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

نعم التعديل والاظافة ليس لها علاقة بالمسلسل انت من تضيفه يدويا فقط يتم فقدانه في حالة حدف الصف

هدية مني لكم هذا كود يختصر الوقت لمستخدمي النافذة الفورية حيث يمسح كامل النصوص/المخرجات السابقة قبل أي إرسال نصوص أو مخرجات جديدة جربوه وزودونا بأي مشاكل تواجهونها للتعديل عليه. Sub DebugClear() 'AbuuAhmed 2024/11/01 Dim WshShell As Object Set WshShell = CreateObject("WScript.Shell") With WshShell .SendKeys "^g", True .SendKeys "^a", True .SendKeys "{DEL}", True End With Set WshShell = Nothing End Sub

العفو تحت امرك 🌹

بارك الله فيك يا استاذى ونفع بك وبعلمك الأمة وجعل عملك هذا فى ميزان حسناتك يوم القيامة

جزاك الله خيرا أخي هذا هو المطلوب

تمت التجربه مسبقاً وكانت نفس النتيجة للأسف 😬

اضف زر فى نموذج tabl1 واضف هذا الكود له Dim filter As String filter = "" If Not IsNull(Me.sana) Then filter = filter & "sana = '" & Me.sana & "' AND " End If If Not IsNull(Me.rakm) Then filter = filter & "rakm = '" & Me.rakm & "' AND " End If If Not IsNull(Me.wadia) Then filter = filter & "wadia = '" & Me.wadia & "' AND " End If If filter <> "" Then filter = Left(filter, Len(filter) - 5) End If DoCmd.OpenForm "tabl", , , filter

وعليكم السلام ورحمة الله وبركاته مساكم الله بالخير تمت التجربة والإفادة شكرا جزيلا على وقتكم الثمين وجزاكم الله خيرا

وعليكم السلام ورحمة الله وبركاته شكرا على الفكرة الجميلة جعفر

السلام عليكم ورحمة الله وبركانه صبحكم الله بالخير جرب الملف وان لم يكتمل حدد ما هو المطلوب لك وافر التقدير والاحترام نقل أعمدة محددة من ورقة الى أكثر من ورقة+222222.xlsm

تفضل أخي @mk_mk_79 Sub CopyHeaders() Dim lastRow As Long, tmp As Long Dim n As Long, Irow As Long, ColArr As Variant Dim WS As Worksheet: Set WS = Sheets("Sheet1") lastRow = WS.Cells(Rows.Count, "F").End(xlUp).Row Irow = 9 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual WS.Range("W" & Irow & ":Y" & WS.Rows.Count).ClearContents tmp = 7 Do While tmp <= lastRow If Not IsEmpty(WS.Cells(tmp, "F")) And Not _ IsEmpty(WS.Cells(tmp, "L")) And Not IsEmpty(WS.Cells(tmp, "R")) Then ColArr = Array(WS.Cells(tmp, "F").Value, _ WS.Cells(tmp, "L").Value, WS.Cells(tmp, "R").Value) n = 0 Do While tmp + n <= lastRow And _ (Not IsEmpty(WS.Cells(tmp + n, "F")) Or _ Not IsEmpty(WS.Cells(tmp + n, "L")) Or _ Not IsEmpty(WS.Cells(tmp + n, "R"))) n = n + 1 Loop With WS.Range(WS.Cells(Irow, "W"), WS.Cells(Irow + n - 1, "W")) .Value = ColArr(0) .Offset(0, 1).Value = ColArr(1) .Offset(0, 2).Value = ColArr(2) End With Irow = Irow + n + 3 tmp = tmp + n Else tmp = tmp + 1 End If Loop Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub طلبات v2 .xls

وعليكم السلام ورحمة الله تعالى وبركاته إليك المثال التالي أقل تاريخ.xlsx

جرب الكود التالى النتيجة فى G2 بمكن تعديلها فى الكود Sub CalculateResult() Dim cellCount As Long Dim result As Variant Dim dataRange As Range Dim cell As Range Set dataRange = Sheets("طباعة").Range("B7:I11") cellCount = 0 For Each cell In dataRange If cell.Value <> 0 And cell.Value <> "" Then cellCount = cellCount + 1 End If Next cell Select Case Sheets("طباعة").Range("F2").Value Case "الأول", "الثانى" If cellCount >= 25 Then result = 25 Else result = cellCount End If Case "الثالث" result = cellCount Case Else result = "" End Select Sheets("طباعة").Range("G2").Value = result MsgBox "تم حساب النتيجة: " & result الملف عدد الخلايا بشروط.xlsx

نعم يمكن ذلك الملف به 3 اكواد عمل المعادلات بكود1.xlsb

إدن لنفترض أننا سنقوم باستخراج البيانات من الأعمدة H:M كما هو ظاهر لديك على الصورة إلى ورقة 2 مثلا Sub CreateShift() Dim lastRow As Long, i As Long, j As Long, kay As String, c As String Dim tbl As Variant, Names As Collection, cell As Range, name As String Dim WS As Worksheet: Set WS = Sheets("Sheet1") Dim dest As Worksheet: Set dest = Sheets("Sheet2") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual If Application.WorksheetFunction.CountA(dest.Cells) > 0 Then dest.UsedRange.Clear lastRow = WS.Cells(WS.Rows.Count, 8).End(xlUp).Row tbl = WS.Range("H4:M" & lastRow).Value For i = 1 To lastRow - 3 dest.Cells(1, i + 1).Value = tbl(i, 2) dest.Cells(2, i + 1).Value = tbl(i, 1) If Application.CountA(Application.Index(tbl, i, 3)) > 0 Then Colors dest.Cells(1, i + 1), RGB(200, 200, 255) Colors dest.Cells(2, i + 1), RGB(255, 153, 0) End If Next i Set Names = New Collection On Error Resume Next For i = 1 To UBound(tbl, 1) For j = 3 To 6 If tbl(i, j) <> "" Then Names.Add tbl(i, j), CStr(tbl(i, j)) Next j Next i On Error GoTo 0 For i = 1 To Names.Count dest.Cells(i + 2, 1).Value = Names(i) Next i With dest.Range("A1:A2") .ClearFormats: .Merge: .Value = "الإســـم": .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter: .Font.Bold = True .Borders.LineStyle = xlContinuous: .Borders.color = RGB(0, 0, 255) .Interior.color = RGB(200, 200, 255) End With For i = 1 To lastRow - 3 For j = 1 To Names.Count If Not IsEmpty(dest.Cells(j + 2, 1)) Then name = Names(j) c = dest.Cells(1, i + 1).Value kay = "" For Each cell In WS.Range("J4:M" & WS.Cells(WS.Rows.Count, 10).End(xlUp).Row) If cell.Value = name And WS.Cells(cell.Row, 9).Value = c Then kay = (cell.Column - 9) & " مخزن" Exit For End If Next cell dest.Cells(j + 2, i + 1).Value = kay With dest.Range(dest.Cells(j + 2, 1), dest.Cells(j + 2, i + 1)) .Borders(xlEdgeBottom).LineStyle = xlContinuous .Borders(xlEdgeBottom).color = RGB(0, 0, 255) End With End If Next j Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub Sub Colors(cell As Range, color As Long) With cell .Interior.color = color .Font.Bold = True .Borders(xlEdgeBottom).LineStyle = xlContinuous End With End Sub New.xlsb

وعليكم السلام ورحمة الله وبركاته ما هو الخطأ الذي يظهر لانه لا يظهر اخطأء بعد وضع بيانات الي الصف ٢٠ ألف

اظن ان الكود المقترح من الاستاد @حسونة حسين يشتغل بشكل جيد على العموم جرب هدا Option Explicit Sub test() Dim arr As Variant, i As Long, Irow As Long Dim tmp1 As Object, tmp2 As Object, c As Variant Dim n As Variant, a As Variant, b As Variant Dim WS As Worksheet: Set WS = Sheets("Sheet1") Application.ScreenUpdating = False With WS Irow = .Columns("A:E").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If Irow > 1 Then .Range("C2:E" & Irow).ClearContents End If arr = .Range("A2:B" & Irow).Value Set tmp1 = CreateObject("Scripting.Dictionary") Set tmp2 = CreateObject("Scripting.Dictionary") For i = 1 To UBound(arr, 1) If arr(i, 1) <> "" Then tmp1(arr(i, 1)) = True If arr(i, 2) <> "" Then tmp2(arr(i, 2)) = True Next i For Each n In tmp1 If tmp2.exists(n) Then c = cnt(c, n) tmp2.Remove n Else a = cnt(a, n) End If Next n For Each n In tmp2 b = cnt(b, n) Next n If Not IsEmpty(a) Then [C2].Resize(UBound(a), 1).Value = WorksheetFunction.Transpose(a) If Not IsEmpty(b) Then [D2].Resize(UBound(b), 1).Value = WorksheetFunction.Transpose(b) If Not IsEmpty(c) Then [E2].Resize(UBound(c), 1).Value = WorksheetFunction.Transpose(c) Application.ScreenUpdating = True End With End Sub Function cnt(arr As Variant, Value As Variant) As Variant If IsEmpty(arr) Then ReDim arr(1 To 1) arr(1) = Value Else ReDim Preserve arr(1 To UBound(arr) + 1) arr(UBound(arr)) = Value End If cnt = arr End Function مقارنة 3.xlsb

تفضل اخى مقارنة.xlsb

وعليكم السلام ورحمه الله وبركاته تفضل مقارنة.xlsb