Listbox multiselect

[Hks99]

السلام عليكم 

ارجوا المساعده 

عندي listbox واريد "اختار اكثر من عنصر" وتغير البيانات للعناصر المختاره على حسب الاسبوع 

مثل لو ضغط على week1  يتغير الاسبوع للعناصر المختاره الى week1 ...وهكذا 

طبعا فيه ملف مرفق وبيكون اوضح 

list.box1.xlsm

[lionheart]

Option Explicit

Private Sub CommandButton1_Click()
    UpdateListBox "WEEK 1"
End Sub

Private Sub CommandButton2_Click()
    UpdateListBox "WEEK 2"
End Sub

Private Sub CommandButton3_Click()
    UpdateListBox "WEEK 3"
End Sub

Private Sub CommandButton4_Click()
    UpdateListBox "WEEK 4"
End Sub

Sub UpdateListBox(ByVal sWeek As String)
    Dim ws As Worksheet, i As Long
    Set ws = ThisWorkbook.Worksheets(1)
    For i = 0 To UserForm1.ListBox1.ListCount - 1
        If UserForm1.ListBox1.Selected(i) Then
            ListBox1.List(i, 4) = sWeek
            ws.Cells(i + 3, 11) = sWeek
        End If
    Next i
    Call CommandButton5_Click
End Sub

Private Sub CommandButton5_Click()
    Dim deg1, deg4, deg6, deg8, deg2 As String, deg3 As String, deg5 As String, deg7 As String, sat As Long, s As Long
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    With ListBox1
        .Clear
        .ColumnCount = 8
        .ColumnWidths = "80;190;100;80;0;110,100"
    End With
    deg2 = "AUGUST"
    deg3 = "AUGUST"
    deg5 = "AUGUST"
    deg7 = "AUGUST"
    For sat = 3 To Sheet1.Cells(65536, "F").End(xlUp).Row
        Set deg1 = Sheet1.Cells(sat, "F")
        Set deg4 = Sheet1.Cells(sat, "G")
        Set deg6 = Sheet1.Cells(sat, "H")
        Set deg8 = Sheet1.Cells(sat, "I")
        If UCase(deg1) Like UCase(deg2) Or UCase(deg3) Like UCase(deg4) Or UCase(deg5) Like UCase(deg6) Or UCase(deg7) Like UCase(deg8) Then
            ListBox1.AddItem
            ListBox1.List(s, 0) = Sheet1.Cells(sat, "A").Value
            ListBox1.List(s, 1) = Sheet1.Cells(sat, "C").Value
            ListBox1.List(s, 2) = Sheet1.Cells(sat, "B").Value
            ListBox1.List(s, 3) = Sheet1.Cells(sat, "D").Value
            ListBox1.List(s, 5) = Sheet1.Cells(sat, "N").Value
            ListBox1.List(s, 6) = Sheet1.Cells(sat, "J").Value
            ListBox1.List(s, 7) = Sheet1.Cells(sat, "K").Value
            s = s + 1
        End If
    Next sat
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

 

[Hks99]

شكرا جزيلا استاذي العزيز ....🌹🌹🌹

[Hks99]

في ١٩‏/١٠‏/٢٠٢١ at 06:51, lionheart said:

Option Explicit

Private Sub CommandButton1_Click()
    UpdateListBox "WEEK 1"
End Sub

Private Sub CommandButton2_Click()
    UpdateListBox "WEEK 2"
End Sub

Private Sub CommandButton3_Click()
    UpdateListBox "WEEK 3"
End Sub

Private Sub CommandButton4_Click()
    UpdateListBox "WEEK 4"
End Sub

Sub UpdateListBox(ByVal sWeek As String)
    Dim ws As Worksheet, i As Long
    Set ws = ThisWorkbook.Worksheets(1)
    For i = 0 To UserForm1.ListBox1.ListCount - 1
        If UserForm1.ListBox1.Selected(i) Then
            ListBox1.List(i, 4) = sWeek
            ws.Cells(i + 3, 11) = sWeek
        End If
    Next i
    Call CommandButton5_Click
End Sub

Private Sub CommandButton5_Click()
    Dim deg1, deg4, deg6, deg8, deg2 As String, deg3 As String, deg5 As String, deg7 As String, sat As Long, s As Long
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    With ListBox1
        .Clear
        .ColumnCount = 8
        .ColumnWidths = "80;190;100;80;0;110,100"
    End With
    deg2 = "AUGUST"
    deg3 = "AUGUST"
    deg5 = "AUGUST"
    deg7 = "AUGUST"
    For sat = 3 To Sheet1.Cells(65536, "F").End(xlUp).Row
        Set deg1 = Sheet1.Cells(sat, "F")
        Set deg4 = Sheet1.Cells(sat, "G")
        Set deg6 = Sheet1.Cells(sat, "H")
        Set deg8 = Sheet1.Cells(sat, "I")
        If UCase(deg1) Like UCase(deg2) Or UCase(deg3) Like UCase(deg4) Or UCase(deg5) Like UCase(deg6) Or UCase(deg7) Like UCase(deg8) Then
            ListBox1.AddItem
            ListBox1.List(s, 0) = Sheet1.Cells(sat, "A").Value
            ListBox1.List(s, 1) = Sheet1.Cells(sat, "C").Value
            ListBox1.List(s, 2) = Sheet1.Cells(sat, "B").Value
            ListBox1.List(s, 3) = Sheet1.Cells(sat, "D").Value
            ListBox1.List(s, 5) = Sheet1.Cells(sat, "N").Value
            ListBox1.List(s, 6) = Sheet1.Cells(sat, "J").Value
            ListBox1.List(s, 7) = Sheet1.Cells(sat, "K").Value
            s = s + 1
        End If
    Next sat
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

 

استاذي العزيز ...

للاسف لما عملت صفوف اكثر لم يعمل الكود بالشكل الصحيح 

عند تغير DH53 و DH54 و DH6 لا تتغير وانما تتغير DH52 و DH51 و DH50 

وايضا عند استخدامه اكثر عن مره لا يعمل ّ....

ولك جزيل الشكر 

list.box2.xlsm