Excel'de çoklu seçim açılır listesi

Question

İçinde birçok (50'den fazla) sayfa olan çalışma kitabım var. 49 sayfada, E sütununda aşağı yukarı açılır listeler var. Açılır liste varsa, listenin kaynağı aynı satırdaki C hücresine bağlıdır. Yani örneğin bağlı olarak. C11, E11 açılır liste1, açılır liste2 veya boş olacaktır. Şimdi 49 sayfanın her birinde, küresel açılır listenin2 çoklu seçim listesi olmasını istiyorum. Kodum aşağıdadır:

Option Explicit

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    
     If Not Sh.Name = "Dane" Then
        With Sh
            Dim Oldvalue As String
            Dim Newvalue As String
            .Protect UserInterfaceOnly:=True
            Application.EnableEvents = True
            On Error GoTo Exitsub
            ' the check to catch a change of single cell only
            If Not Target.Rows.Count > 1 And Target.Columns.Count > 1 Then
                ' check that this cell in column "E" (concept #2)
                If Not Intersect(Target, .Columns(5)) Is Nothing Then
                    'check if this is validation data cell
                    If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
                      GoTo Exitsub
                    Else: If .Target.Value = "" Then GoTo Exitsub Else
                      Application.EnableEvents = False
                      Newvalue = Target.Value
                      Application.Undo
                      Oldvalue = Target.Value
                        If Oldvalue = "" Then
                          Target.Value = Newvalue
                        Else
                            If InStr(1, Oldvalue, Newvalue) = 0 Then
                              Target.Value = Oldvalue & ", " & Newvalue
                            Else:
                              Target.Value = Oldvalue
                            End If
                        End If
                     End If
                End If
            End If
            Application.EnableEvents = True
        End With
    End If
    
Exitsub:
    Application.EnableEvents = True
    
End Sub 

Şimdi bu kod This_workbook'daysa işe yaramıyor gibi görünüyor ve aşağıdaki ile birlikte belirli bir sayfa vba'sına koyarsam işe Worksheet_Changeyarıyor. Ayrıca şimdilik bu kod hem dropdownlist1 hem de dropdownlist2 için çalışacak. Bunu nasıl düzeltebilirim?

Answer 1

Yani benim kodumda hata vardı. Her zaman tek bir hücreyi kastediyordum, kontrol edildi: If Not Target.Rows.Count > 1 And Target.Columns.Count > 1 Thenama sonra Ve operatörü eksik değildi. Bu şekilde çalışmak için 1'den fazla hücreyi ayrı sütunlarda düzenlemeliyim. Aşağıdaki kod sabittir.

Option Explicit

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    
     If Not Sh.Name = "Dane" Then
        With Sh
            Dim Oldvalue As String
            Dim Newvalue As String
            .Protect UserInterfaceOnly:=True
            Application.EnableEvents = True
            On Error GoTo Exitsub
            ' the check to catch a change of single cell only
            If Not Target.Rows.Count > 1 And Not Target.Columns.Count > 1 Then
                ' check that this cell in column "E" (concept #2)
                If Not Intersect(Target, .Columns(5)) Is Nothing Then
                    'check if this is validation data cell
                    If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
                      GoTo Exitsub
                    Else: If .Target.Value = "" Then GoTo Exitsub Else
                      Application.EnableEvents = False
                      Newvalue = Target.Value
                      Application.Undo
                      Oldvalue = Target.Value
                        If Oldvalue = "" Then
                          Target.Value = Newvalue
                        Else
                            If InStr(1, Oldvalue, Newvalue) = 0 Then
                              Target.Value = Oldvalue & ", " & Newvalue
                            Else:
                              Target.Value = Oldvalue
                            End If
                        End If
                     End If
                End If
            End If
            Application.EnableEvents = True
        End With
    End If
    
Exitsub:
    Application.EnableEvents = True
    
End Sub