Ja, du könntest deine Datenumgebung besser beschreiben !
so - als allgemeines Beispiel :
'******************************************************************************
' Modul: mdl_Grunddaten / erstellt : 12.11.2014
'------------------------------------------------------------------------------
' Rohdaten aus externer Quelle
' Aufbau E:\Temp\DropDownGrund.xlsx
' Tabelle - Rohdaten
' Spalte A - Kunde-Nr: - StringZahl (1000 - )
' Spalte B - Brutto - Dezimal 2
' Spalte C - Staffel 1 - Dezimal 2
' Spalte D - Staffel 2 - Dezimal 2
'
' DropDown im aktuellen Arbeitsblatt
''******************************************************************************
Option Explicit
Dim oList As Object
Dim aVald()
Sub NewValidation()
'
'******************************************************************************
' Name : NewValidation / erstellt : 12.11.2014 / 18:52 / Sub
'------------------------------------------------------------------------------
'
' in aktueller Excel Datei !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
' an Const ZELLADRESSE DropDown(Validation) aus den Angaben zur Rohdatendatei
'
'******************************************************************************
'
' Fehlerbehandlung
'------------------------------------------------------------------------------
Const m_ModName As String = "mdl_Grunddaten"
Const m_PrcName As String = "NewValidation"
Dim m_SendKey As String: m_SendKey = Chr(123) & "F8" & Chr(125)
'------------------------------------------------------------------------------
'
Const ZELLADRESSE As String = "B2"
' Angaben zur Rohdatendatei
Const ROHDATEN As String = "E:\Temp\DropDownGrund.xlsx"
Const TABELLE As String = "Rohdaten"
Const BEREICH As String = "A:D"
Const SPALTE As Long = 1 'hier Kunden-Nr:
'
On Error GoTo NewValidation_Error
'
Set oList = CreateObject("System.Collections.ArrayList")
GetDataToList ROHDATEN, TABELLE, BEREICH, SPALTE
'Debug.Print Join(oList.toarray(), Chr(10))
MkValidation ZELLADRESSE
'
On Error GoTo 0
'
NewValidation_Error:
'------------------------------------------------------------------------------
Select Case Err.Number
Case Is = 0: 'errorless
' Case is = #: 'custom
Case Else: 'display
Select Case MsgBox(Format(Err.Number, " #0") & "/" & Err.Description & _
Chr(13) & Chr(13) & " Debugmodus starten ?", _
vbYesNo Or vbCritical Or vbDefaultButton1, _
m_ModName & " / " & m_PrcName)
Case vbYes
Application.SendKeys Keys:=m_SendKey & m_SendKey, Wait:=False
Stop: Resume
Case vbNo
' Abbruch
End Select
End Select
'------------------------------------------------------------------------------
End Sub
Private Sub GetDataToList(ByVal sFileFullName As String, _
sSheetName As String, sSheetRange As String, lColumn As Long)
Const SEL_FROM As String = "SELECT * FROM "
Dim oConn As Object
Dim oRS As Object
Dim sConnect As String
Dim sSQL As String
Dim lField As Long
Dim rs As Variant
sConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & sFileFullName & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"""
sSQL = SEL_FROM & Chr(91) & sSheetName & Chr(36) & sSheetRange & Chr(93)
Set oRS = CreateObject("ADODB.Recordset")
oRS.Open sSQL, sConnect, 0, 1, 1
lField = lColumn - 1
With oList
Do Until oRS.EOF
rs = oRS.Fields(lField)
If Not .contains(rs) Then oList.Add rs
oRS.MoveNext
Loop
.Sort
aVald = .toarray
End With
oRS.Close
Set oRS = Nothing
End Sub
Private Sub MkValidation(ByVal sAddi As String)
Dim c As Range
Set c = Range(sAddi)
With c.Validation
.Delete
.Add Type:=xlValidateList, _
Operator:=xlEqual, _
Formula1:=Join(aVald, ",")
End With
End Sub
|