Per DropDown ausgewählte Namen in Array übergeben
05.08.2019 10:48:00
Marvin
Ich brauche nochmals eure Hilfe.
Ich habe ein Programm geschrieben, was mir den Namen eines Worksheets mit dem Namen in einer bestimmten Zelle in diesem Worksheet vergleicht. Wenn beide übereinstimmen wird ein Array gebildet in dem alle Namen aufgelistet sind, die Übereinstimmen. ( Code 1)
Im Anschluss möchte ich mir genau diese Liste als Drop Down Auswahl generieren (Code 2)
Beides Klappt auch soweit ganz gut. Ich habe mein Array als Projecttyp deklariert weil ich verschiedene Eigenschaften benötige wo ich auch zu meinem Problem komme. Ich möchte im Enddeffekt 2 Arrays haben. Das erste ist das, was ich oben beschrieben habe. Alle Namen die mit ihrem Worksheets übereinstimmen sollen dort mit dem Boolean Status False aufgelistet sein. Sobald man diese per Drop Down Liste ausgewählt hat soll sich der Status auf True ändern und in ein neues Array (mein zweites Array) übergeben werden. Ich hoffe das ist soweit verständlich. Der Status True und False soll quasi die Eigenschaft Ausgewählt und nicht ausgewählt sein. Es wäre super wenn nichts an dem beiden Codes geändert werden muss.
Wenn mir also jemand helfen kann einen Code 3 für mein Problem zu schreiben wäre das super und ich gebe gerne ein kühles Getränk aus, wenn es möglich ist (:
Code 1:
Option Explicit
'##########################################################'
'Defining own Type for all Projectsheets'
'##########################################################'
Public Type Projecttyp
Name As String
Status As Boolean
Index As String
End Type
'##########################################################'
'Compare all Worksheet Names with a defined Cellname. If the Worksheet Name is like the Name in _ the defined Cell then put all Sheets in one Array'
'##########################################################'
Public Function Projectarray() As Projecttyp()
Dim Sheetname As String
Dim Cellname As String
Dim i As Long, j As Long
Dim Compare As Long
'Workbook.Open
'Compare Name from all Worksheets with Cellname in defined Cell'
For i = 1 To ThisWorkbook.Worksheets.Count
Sheetname = Sheets(i).Name
Cellname = Sheets(i).Range("D2")
Compare = InStr(1, Cellname, Sheetname, vbTextCompare)
'All Names from Worksheets which are like the Name in the defined Cell are listed in _
array wsName()'
If Compare > 0 Then
j = j + 1
ReDim Preserve WSArray(1 To j)
With WSArray(j)
.Name = Sheets(i).Name
.Index = i
.Status = False
End With
End If
Next i
'Return the Values from wsName'
Projectarray = WSArray
End Function
Option Explicit
'########################################################################
'Proof if the function Projectarray Return is a array. If the return is not a array, the loop will generate a error
'########################################################################
Private Declare PtrSafe Function SafeArrayGetDim Lib "oleaut32.dll" ( _
ByRef psa() As Any) As Long
'########################################################################
'Generate a DropDown Menu for all the Worksheets, which are Projectworksheets. The Name and the Number of the Worksheets a generated in the function projectarray
'Select a Cell wich is in the below defined Range to choose which Projectname shall be listed from the DropDown Menu'
'########################################################################
Private Sub Worksheet_SelectionChange(ByVal target As Range)
Dim DDName As String
Dim j As Integer
'Define the Range where u can choose the Projects with the DropDown Menu'
If Not Intersect(target, Range("B" & cRStart & " :B" & cREnd)) Is Nothing Then
'Calling the function Projectarray and define the Varible wsName() as the array from _
Projectarray'
WSArray() = Projectarray
'Proof if WSArray() is a array from the return from Projectarray'
If SafeArrayGetDim(WSArray) 0 Then
Application.ScreenUpdating = False
'Loop to Define the array as a String for the DropDown Menu'
For j = LBound(WSArray) To UBound(WSArray)
DDName = DDName & WSArray(j).Name & ","
Next
DDName = Left$(DDName, Len(DDName) - 1)
'Generate DropDownMenu in the Cell which is in the Range'
With ActiveCell
.Validation.Delete
.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlGreater, Formula1:=DDName
.Validation.IgnoreBlank = True
.Validation.InCellDropdown = True
.Validation.ShowInput = True
End With
Application.ScreenUpdating = True
'For proofing if WSArray() is a array'
End If
End If
End Sub