AW: DateiVerzeichnis ComboBox
18.12.2006 13:48:23
Heiko
Hallo Joe,
na weil nächstes Wochenende Weihnachten ist will ich mal Geschenke auspacken.Die Combobox muss drei Spalten haben und ich geh davon das in den Dateien die du einliest die Tabelle KALK vorhanden ist, wenn nicht dann gibt es eine Fehlermeldung.
Option Explicit
Private Sub CommandButton1_Click()
Dim fs, f, f1, fc, s
Dim lngI As Long
Dim strPath As String
' Pfad anpassen
strPath = "H:\EXCEL\Muell"
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(strPath)
Set fc = f.Files
lngI = 0
For Each f1 In fc
UserForm1.ComboBox1.AddItem f1.Name
Set s = fs.getfile(f1)
UserForm1.ComboBox1.List(lngI, 1) = s.datecreated
If InStr(1, s.Type, "Excel") > 0 Then
UserForm1.ComboBox1.List(lngI, 2) = GetValue(strPath, s.Name, "KALK", "D7")
End If
lngI = lngI + 1
Next
SortBox UserForm1.ComboBox1, 2, 2, 3
UserForm1.ComboBox1.ListIndex = 0
End Sub
Public Sub SortBox(cltBox As Control, intSpalten As Integer, _
intSpalte As Integer, Optional bytWie As Byte = 1)
' So DIS 28.04.05
' SortBox sortiert nicht gebundene List- und Comboboxen. Gebundene List- und Comboboxen
' (Angabe bei RowSource oder ListFillRange) können NICHT sortiert werden.
' cltBox : Name der Listbox die sortiert werden soll.
' intSpalten : Wieviele Spalten sollen mit sortiert werden. Sollte der Anzahl der Spalten
' in der Listbox entsprechen
' intSpalte : Nach welcher Spalte soll sortiert werden.
' bytWie : 1 oder Nicht angegeben als Text
' : 2 als Zahl, dann muß die ganze Spalte Zahlen enthalten.
' : 3 als Datum, dann muß die ganze Spalte Datumwerte enthalten.
' Aufruf zum Beispiel so: ListBox1 mit 7 Spalten, Sortierung nach Spalte 1 Sortierordnung Text
' SortBox ListBox1, 7, 1 oder SortBox ListBox1, 7, 1, 1
' Oder so : Listbox17 mit 2 Spalten, Sortierung nach Spalte 2 Sortierordnung Zahlen
' SortBox ListBox17, 2, 2, 2
Dim intLast As Integer, intNext As Integer, intCounter As Integer, intFehler As Integer
Dim strTmp As String, strFehlertext As String
Dim variLast As Variant, variNext As Variant
On Error GoTo Errorhandler
intFehler = 0
With cltBox
For intLast = 0 To .ListCount - 1
For intNext = intLast + 1 To .ListCount - 1
Select Case bytWie
Case 1
intFehler = 0
variLast = CStr(.List(intLast, intSpalte - 1))
variNext = CStr(.List(intNext, intSpalte - 1))
Case 2
intFehler = 1
variLast = CDbl(.List(intLast, intSpalte - 1))
variNext = CDbl(.List(intNext, intSpalte - 1))
Case 3
intFehler = 2
variLast = CDate(.List(intLast, intSpalte - 1))
variNext = CDate(.List(intNext, intSpalte - 1))
End Select
intFehler = 0
If variLast > variNext Then
For intCounter = 0 To intSpalten - 1
strTmp = CStr(.List(intLast, intCounter))
.List(intLast, intCounter) = CStr(.List(intNext, intCounter))
.List(intNext, intCounter) = strTmp
Next intCounter
End If
Next intNext
Next intLast
End With
Exit Sub
Errorhandler:
Select Case intFehler
Case 0
strFehlertext = "In der Listbox Sortierung ist ein Fehler aufgetreten !"
Case 1
strFehlertext = "Nicht alle Werte in der zu sortierenden Spalte sind Zahlen !"
Case 2
strFehlertext = "Nicht alle Werte in der zu sortierenden Spalte sind Datumswerte !"
Case Else
strFehlertext = "Unerwarteter Fehler !"
End Select
MsgBox strFehlertext & " Bitte informieren Sie 'So' ! " & vbCr & vbCr & _
"Fehler aufgetreten in " & cltBox.Name & " !" & vbCr & _
"Fehlernummer = " & Err.Number & vbCr & _
"Fehlerbeschreibung = " & Err.Description & vbCr & _
"Fehlersource = " & Err.Source, vbCritical, " Meldung vom Makro SortBox !"
End Sub
Function GetValue(path, file, sheet, ref)
' VBA Function to Get a Value From a Closed File
' VBA does not include a method to retrieve a value from a closed file. You can, however,
' take advantage of Excel's ability to work with linked files.
' This tip contains a VBA function that retrieves a value from a closed workbook.
' It does by calling an XLM macro.
' The GetValue function, listed below takes four arguments:
' path: The drive and path to the closed file (e.g., "d:\files")
' file: The workbook name (e.g., "99budget.xls")
' sheet: The worksheet name (e.g., "Sheet1")
' ref: The cell reference (e.g., "C4")
' Aufruf z.B. i = GetValue("C:\test", "test1.xls", "Tabelle1", "A1")
' Retrieves a value from a closed workbook
Dim arg As String
' Make sure the file exists
If Right(path, 1) <> "\" Then path = path & "\"
If Dir(path & file) = "" Then
GetValue = "File Not Found"
Exit Function
End If
' Create the argument
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)
' Execute an XLM macro
GetValue = ExecuteExcel4Macro(arg)
End Function
Gruß Heiko
PS: Rückmeldung wäre nett !