السلام عليكم ممكن تعديل على الكود ليعمل على ملف اخر

ابو مارفن · مارس 12

Public Property Get CrWS() As Worksheet
    Set CrWS = Sheets("ورقة1")
End Property

Private Sub UserForm_Initialize()
    Dim Tbl As Object, c As Range, temp As Variant, lastRow As Long
    Set Tbl = CreateObject("Scripting.Dictionary")
    lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row
    
    If lastRow > 1 Then
        For Each c In CrWS.Range("B2:B" & lastRow)
            If c.Value <> "" Then Tbl.Item(c.Value) = c.Value
        Next c
    End If
    
    If Tbl.Count > 0 Then
        temp = Tbl.items
        Me.ComboBox1.List = temp
    End If
End Sub

Private Sub CommandButton1_Click()
    Dim lastRow As Long, ky As String
    If Me.ComboBox1.Value <> "" Then
    ky = "=*" & Me.ComboBox1.Value & "*"
    lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row

    If lastRow < 2 Then Exit Sub

    Application.ScreenUpdating = False
    With CrWS.Range("B1:B" & lastRow)
        .AutoFilter Field:=1, Criteria1:=ky
    End With

    On Error Resume Next
    CrWS.Range("A2:C" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    On Error GoTo 0
    CrWS.AutoFilterMode = False
    Application.ScreenUpdating = True
    Unload Me
    End If
End Sub

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

كلية.xlsb ملف الاصلي.xlsb

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

hegazee · مارس 12

تفضل

كلية1.xlsb

ابو مارفن · مارس 12

مشكور على ردك استاذ انا اقصد ان يتم العمل على ملف الكليه دون اضافة الكود في الملف اي ان يتم التنفيذ الكود من كود الملف الاصلي ( يعني في حال عندي ملفات اخرى اقوم فقط بتغيير اسم الملف في كود الملف الاصلي واسم الشيت ليتم تنفيذه على الملف المطلوب)ويكون الملفان مفتوحان بنفس الوقت تحياتي لك

تم تعديل مارس 12 بواسطه ابو مارفن

**محمد هشام.** · مارس 13

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

Public Property Get CrWS() As Worksheet
    Dim wbName As String, wsName As String
    wbName = "كلية.xlsb"
    wsName = "قسم"
    On Error Resume Next
    Set CrWS = Workbooks(wbName).Sheets(wsName)
    On Error GoTo 0
End Property

Private Sub UserForm_Initialize()
    Dim Tbl As Object, c As Range, temp As Variant, lastRow As Long
    Set Tbl = CreateObject("Scripting.Dictionary")
    
    If Not CrWS Is Nothing Then
        lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row
        If lastRow > 1 Then
            For Each c In CrWS.Range("B2:B" & lastRow)
                If c.Value <> "" Then Tbl.Item(c.Value) = c.Value
            Next c
        End If
        If Tbl.Count > 0 Then
            temp = Tbl.Items
            Me.ComboBox1.List = temp
        End If
    Else
    MsgBox "المصنف أو الورقة المحددة غير موجودة", vbExclamation

    End If
End Sub

Private Sub CommandButton1_Click()
    Dim lastRow As Long, ky As String
    If Me.ComboBox1.Value <> "" Then
        If Not CrWS Is Nothing Then
            ky = "=*" & Me.ComboBox1.Value & "*"
            lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row
            If lastRow < 2 Then Exit Sub
            Application.ScreenUpdating = False
            With CrWS.Range("B1:B" & lastRow)
                .AutoFilter Field:=1, Criteria1:=ky
            End With
            On Error Resume Next
            CrWS.Range("A2:C" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            On Error GoTo 0
            CrWS.AutoFilterMode = False
            Application.ScreenUpdating = True
            '  اختار ما يناسبك
            UserForm_Initialize
            'OR
           ' Unload Me
        End If
    End If
End Sub

TEST.zip

ابو مارفن · مارس 13

عاشت ايدك استاذنا العزيز هل يمكن ان يظهر الكود في حال وجود خلية فارغة ليتم اختيارها ومسح الصفوف الفارغة كما في الملف المرفق

Private Sub UserForm_Initialize()
Dim r As Long, r1 As Long, r2 As Long
r2 = Range("xfd10000").End(xlUp).Row
Range("XFD1:XFD" & r2).ClearContents
r = Range("B10000").End(xlUp).Row
    Range("B2:B" & r).Copy
    Range("xfd1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveSheet.Range("$xfd$1:$xfd$" & r).RemoveDuplicates Columns:=1, Header:=xlNo
r1 = Range("xfd10000").End(xlUp).Row
Me.ComboBox1.RowSource = ("xfd1:xfd" & r1)
Me.ComboBox1.Value = Range("xfd1").Value

End Sub

.الله يحفظك ويبارك بجهزدك ويجعلها بميزان حسناتك تحياتي لك

تعديل صفوف الكلمات المختاره او صفوف الخلايا الفارغة عند اختيارها.xlsm

تم تعديل مارس 13 بواسطه ابو مارفن

**محمد هشام.** · مارس 14

الكود الدي أشرت إليه دوره هو نسخ القيم من عمود B و نسخها الى عمود XFD وازالة التكرارات منه ثم تعيين مصدر بيانات الكومبوبوكس من نفس العمود

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

 For Each c In CrWS.Range("B2:B" & lastRow)
                If c.Value <> "" Then Tbl.Item(c.Value) = c.Value
            Next c
        End If
        If Tbl.Count > 0 Then
            temp = Tbl.Items
            Me.ComboBox1.List = temp

17 ساعات مضت, ابو مارفن said:

هل يمكن ان يظهر الكود في حال وجود خلية فارغة ليتم اختيارها ومسح الصفوف الفارغة كما في الملف المرفق

لست مـتأكدا مما تحاول فعله لاكن إدا كنت تقصد أنك تريد حدف الصفوف الفارغة عند إختيارك فراغ من الكومبوبوكس جرب هدا التعديل

Public Property Get CrWS() As Worksheet
    Dim wbName As String, wsName As String
    wbName = "كلية.xlsb"
    wsName = "قسم"
    On Error Resume Next
    Set CrWS = Workbooks(wbName).Sheets(wsName)
    On Error GoTo 0
End Property
Private Sub UserForm_Initialize()
    Dim Tbl As Object, c As Range, temp As Variant, lastRow As Long
    Set Tbl = CreateObject("Scripting.Dictionary")
    
    If Not CrWS Is Nothing Then
        lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row
        If lastRow > 1 Then
            For Each c In CrWS.Range("B2:B" & lastRow)
                Tbl.Item(c.Value) = c.Value
            Next c
        End If
        If Tbl.Count > 0 Then
            temp = Tbl.Items
            Me.ComboBox1.List = temp
        End If
    Else
        MsgBox "المصنف أو الورقة المحددة غير موجودة", vbExclamation
    End If
End Sub

Private Sub CommandButton1_Click()
    Dim lastRow As Long, ky As String
    If Me.ComboBox1.Value <> "" Then
        If Not CrWS Is Nothing Then
            ky = "=*" & Me.ComboBox1.Value & "*"
            lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row
            If lastRow < 2 Then Exit Sub
            Application.ScreenUpdating = False
            CrWS.Range("B1:B" & lastRow).AutoFilter Field:=1, Criteria1:=ky
            On Error Resume Next
            CrWS.Range("A2:C" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            On Error GoTo 0
            CrWS.AutoFilterMode = False
            Application.ScreenUpdating = True
            UserForm_Initialize
        End If
    Else
        If Not CrWS Is Nothing Then
            lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row
            If lastRow < 2 Then Exit Sub
            Application.ScreenUpdating = False
            For i = lastRow To 2 Step -1
                If IsEmpty(CrWS.Cells(i, "B").Value) Then CrWS.Rows(i).Delete
            Next i
            Application.ScreenUpdating = True
            UserForm_Initialize
        End If
    End If
End Sub

إما بخصوص تنفيد الكود على نفس المصنف الأخير

تعديل صفوف الكلمات المختاره او صفوف الخلايا الفارغة عند اختيارها.xlsm

تم تعديل مارس 14 بواسطه محمد هشام.

ابو مارفن · مارس 14

عاشت اناملك استاذنا العزيز الله يجعلها بميزان حسناتك تحياتي لحظرتك

ابو مارفن · مارس 15

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

ابو مارفن · مارس 15

في 14‏/3‏/2025 at 03:43, محمد هشام. said:

Public Property Get CrWS() As Worksheet
    Dim wbName As String, wsName As String
    wbName = "كلية.xlsb"
    wsName = "قسم"
    On Error Resume Next
    Set CrWS = Workbooks(wbName).Sheets(wsName)
    On Error GoTo 0
End Property
Private Sub UserForm_Initialize()
    Dim Tbl As Object, c As Range, temp As Variant, lastRow As Long
    Set Tbl = CreateObject("Scripting.Dictionary")
    
    If Not CrWS Is Nothing Then
        lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row
        If lastRow > 1 Then
            For Each c In CrWS.Range("B2:B" & lastRow)
                Tbl.Item(c.Value) = c.Value
            Next c
        End If
        If Tbl.Count > 0 Then
            temp = Tbl.Items
            Me.ComboBox1.List = temp
        End If
    Else
        MsgBox "المصنف أو الورقة المحددة غير موجودة", vbExclamation
    End If
End Sub

Private Sub CommandButton1_Click()
    Dim lastRow As Long, ky As String
    If Me.ComboBox1.Value <> "" Then
        If Not CrWS Is Nothing Then
            ky = "=*" & Me.ComboBox1.Value & "*"
            lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row
            If lastRow < 2 Then Exit Sub
            Application.ScreenUpdating = False
            CrWS.Range("B1:B" & lastRow).AutoFilter Field:=1, Criteria1:=ky
            On Error Resume Next
            CrWS.Range("A2:C" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            On Error GoTo 0
            CrWS.AutoFilterMode = False
            Application.ScreenUpdating = True
            UserForm_Initialize
        End If
    Else
        If Not CrWS Is Nothing Then
            lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row
            If lastRow < 2 Then Exit Sub
            Application.ScreenUpdating = False
            For i = lastRow To 2 Step -1
                If IsEmpty(CrWS.Cells(i, "B").Value) Then CrWS.Rows(i).Delete
            Next i
            Application.ScreenUpdating = True
            UserForm_Initialize
        End If
    End If
End Sub

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

**محمد هشام.** · مارس 15

3 ساعات مضت, ابو مارفن said:

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

صراحة لم أفهم ما تقصده . هل أنت بحاجة لتحديد فراغ بالكومبوبوكس لحدف الصفوف أم تريد فقط عند تنفيد الكود بعد تحديد اسم كلية معينة ان يتم إزالة الصفوف الخاصة بها مع حدف الصفوف الفارغة أي لا تتضمن قيمة في عمود b

ابو مارفن · مارس 15

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

تم تعديل مارس 15 بواسطه ابو مارفن

**محمد هشام.** · مارس 15

هناك شيئ غير مفهوم يرجى ارفاق عينة للبيانات مع شكل النتائج المتوقعة بعد تنفيد الكود

تم تعديل مارس 15 بواسطه محمد هشام.

**محمد هشام.** · مارس 15

24 دقائق مضت, ابو مارفن said:

وعند اختيار خليه فارغة يتم حذف صف الخليه الفارغة وعند اختيار خليه تحتوي على فراغ يمسح صف الخليه التي تحتوي على فراغ

ما هو الفرق بين الخلية الفارغة والخلية التي تحتوي على فراغ بالنسبة لك

ابو مارفن · مارس 15

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

في الكود اعلاه يعمل بشكل ممتاز عند اختيار خليه فارغ يمسح صفها

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

**محمد هشام.** · مارس 15

نعم لان الاسماء لديك كلها تتضمن مسافة فارغة بين الاسماء

كلية التربية

كلية الاداره والاقتصاد

قسم المحاسبة

ابو مارفن · مارس 15

غدا سارفع ملف توضيح للمطلوب قبل التنفيذ والنتيجة تقبل تحياتي

**محمد هشام.** · مارس 15

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

ky = "=*" & Me.ComboBox1.Value & "*"

الى 

ky = Me.ComboBox1.Value

ابو مارفن · مارس 17

TEST 1.rar

**محمد هشام.** · مارس 17

في 15‏/3‏/2025 at 19:45, ابو مارفن said:

مثل نختار اسم يتم حذف صف الاسم المختار وعند اختيار خليه فارغة يتم حذف صف الخليه الفارغة وعند اختيار خليه تحتوي على فراغ يمسح صف الخليه التي تحتوي على فراغ

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

الطلب رقم 2

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

وكذلك عند اختيار خلية تحتوى على رقم لا يمسح الصف

جرب هل هدا ما تقصده

Private Sub CommandButton1_Click()
    Dim lastRow As Long, ky As String, c As Range
    If Me.ComboBox1.Value <> "" Then
        If Not CrWS Is Nothing Then
            lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row
            If lastRow < 2 Then Exit Sub
            Application.ScreenUpdating = False
            
            For Each c In CrWS.Range("B2:B" & lastRow)
                If c.Value = Me.ComboBox1.Value Then
                    If Not IsNumeric(c.Value) And c.Value <> "" Then
                        c.EntireRow.Delete
                    End If
                End If
            Next c
            
            Application.ScreenUpdating = True
            UserForm_Initialize
        End If
    End If
End Sub

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

Private Sub UserForm_Initialize()
    Dim Tbl As Object, c As Range, temp As Variant, lastRow As Long
    Set Tbl = CreateObject("Scripting.Dictionary")
    
    If Not CrWS Is Nothing Then
        lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row
        If lastRow > 1 Then
            For Each c In CrWS.Range("B2:B" & lastRow)
                If Not IsNumeric(c.Value) And c.Value <> "" Then
                    Tbl.Item(c.Value) = c.Value
                End If
            Next c
        End If
        If Tbl.Count > 0 Then
            temp = Tbl.Items
            Me.ComboBox1.List = temp
        End If
    Else
        MsgBox "المصنف أو الورقة المحددة غير موجودة", vbExclamation
    End If
End Sub

TEST 2.rar

ابو مارفن · مارس 17

السلام عليكم استاذ محمد اسف ان لم اوصل لك المطلوب بشكل دقيق

فانا احتاج ان تظهر كل الخلايا العمود ومنها الخلايا الفارغة وخلايا التي تحتوي على فراغ وخلايا الارقام لمسح الصف المختار اذا كان الاختيار خليه الرقم فيمسح صف الخليه المختاره وعند اختيار خليه فارغة فيمسح صف الخليه الفارغة وعند اختيار خليه تحتوي على فراغ فيمسح صف الخليه التي تحتوي على فراغ

تحياتي لحظرتك وشكرا لجهودك

**محمد هشام.** · مارس 18

إدن لنجرب هدا

1) إظهار جميع القيم الموجودة بالعمود سواءا رقمية أو نصية وكدالك الفراغات بعد تمييزها بكلمة فارغة

2) عند اختيار قيمة معينة من عنصر الكومبوبوكس سواءا نصية أو رقمية سيتم حدف الصفوف التي تتضمن القيمة المحددة

3) لجدف الصفوف الفارغة قم بتحديد كلمة فارغة من عنصر كومبوبوكس 1

4) تمت إظافة دالة لترتيب القيم أبجديا على عنصر كومبوبوكس1 لتسهيل العثور على القيمة المطلوبة

5) تم إظافة إعادة ترقيم البيانات على عمود A عند الحدف في حالة كنت بحاجة لدالك

Private Sub UserForm_Initialize()
    Dim Tbl As Object, c As Range, temp As Variant, lastRow As Long
    Set Tbl = CreateObject("Scripting.Dictionary")
   
    If Not CrWS Is Nothing Then
        lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row
        If lastRow > 1 Then
            For Each c In CrWS.Range("B2:B" & lastRow)
                If Trim(c.Value) <> "" Then
                    Tbl.Item(c.Value) = c.Value
                End If
            Next c
        End If
        
        If Application.WorksheetFunction.CountBlank(CrWS.Range("B2:B" & lastRow)) > 0 Then
            Tbl.Item("فارغة") = "فارغة"
        End If
        
        If Tbl.Count > 0 Then
            temp = Tbl.Items
            Call Tri(temp, LBound(temp), UBound(temp))
            Me.ComboBox1.List = temp
        End If
    Else
        MsgBox "المصنف أو الورقة المحددة غير موجودة", vbExclamation
    End If
End Sub

Private Sub CommandButton1_Click()
    Dim lastRow As Long, ky As Variant, c As Range, OnRng As Range
    If Me.ComboBox1.Value <> "" Then
        If Not CrWS Is Nothing Then
            ky = Me.ComboBox1.Value
            lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row
            If lastRow < 2 Then Exit Sub
            Application.ScreenUpdating = False
            
            If ky = "فارغة" Then
                For Each c In CrWS.Range("B2:B" & lastRow)
                    If Trim(c.Value) = "" Then
                        If OnRng Is Nothing Then
                            Set OnRng = c.EntireRow
                        Else
                            Set OnRng = Union(OnRng, c.EntireRow)
                        End If
                    End If
                Next c
            Else
                For Each c In CrWS.Range("B2:B" & lastRow)
                    If IsNumeric(c.Value) And IsNumeric(ky) Then
                        If CDbl(c.Value) = CDbl(ky) Then
                            If OnRng Is Nothing Then
                                Set OnRng = c.EntireRow
                            Else
                                Set OnRng = Union(OnRng, c.EntireRow)
                            End If
                        End If
                    Else
                        If Trim(c.Value) = Trim(ky) Then
                            If OnRng Is Nothing Then
                                Set OnRng = c.EntireRow
                            Else
                                Set OnRng = Union(OnRng, c.EntireRow)
                            End If
                        End If
                    End If
                Next c
            End If
            
            If Not OnRng Is Nothing Then
                OnRng.Delete
            End If
            
            With CrWS.Range("A2:A" & CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row)
                .Value = Evaluate("ROW(" & .Address & ")-1")
            End With
            
            UserForm_Initialize
            Me.ComboBox1.Value = ""
            Application.ScreenUpdating = True
        End If
    End If
End Sub

Sub Tri(a, gauc, droi)
    ref = a((gauc + droi) \ 2)
    g = gauc: d = droi
    Do
        Do While a(g) < ref: g = g + 1: Loop
        Do While ref < a(d): d = d - 1: Loop
        If g <= d Then
            temp = a(g): a(g) = a(d): a(d) = temp
            g = g + 1: d = d - 1
        End If
    Loop While g <= d
    If g < droi Then Call Tri(a, g, droi)
    If gauc < d Then Call Tri(a, gauc, d)
End Sub

وأي إستفسار أو تعديل سوف نكون سعداء دائما بحصولك على النتائج المطلوبة

بالتوفيق ........

TEST 3.rar

تم تعديل مارس 18 بواسطه محمد هشام.

ابو مارفن · مارس 18

عاشت ايدك استاذي العزيز الله يحفظك ويبارك بجهودك مشكوووور تحياتي لحظرتك

الله يجعلها بميزان حسناتك

تسجيل الدخول

السلام عليكم ممكن تعديل على الكود ليعمل على ملف اخر

الردود الموصى بها

ابو مارفن

hegazee

ابو مارفن

محمد هشام.

ابو مارفن

محمد هشام.

ابو مارفن

ابو مارفن

ابو مارفن

محمد هشام.

ابو مارفن

محمد هشام.

محمد هشام.

ابو مارفن

محمد هشام.

ابو مارفن

محمد هشام.

ابو مارفن

محمد هشام.

ابو مارفن

محمد هشام.

ابو مارفن

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information