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

[ابو مارفن]

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

تم تعديل الأربعاء at 07:28 بواسطه ابو طيبه
اضافة مرفقات

[hegazee]

تفضل

كلية1.xlsb

[ابو مارفن]

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

تم تعديل الأربعاء at 11:28 بواسطه ابو مارفن

[محمد هشام.]

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

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

[ابو مارفن]

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

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

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

[محمد هشام.]

الكود الدي أشرت إليه  دوره هو نسخ القيم من عمود   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

تم تعديل منذ 1 ساعه بواسطه محمد هشام.