AW: Inputbox für VBA Befehl
05.01.2009 16:27:29
Tom
Hallo,
ich hoffe das hilft Dir weiter.
Option Explicit
Dim Liste As String
Dim FS As Object
Dim varFolder
Sub ListOrdner(myFolder, Optional sFilter As String = "*.*")
Dim myFile As Object, mySubfolders As Object
Set myFolder = FS.getfolder(myFolder)
On Error GoTo FehlerZugriff
For Each myFile In myFolder.Files
If myFolder = varFolder Then Exit For
If myFile.Path Like sFilter Then
Liste = Liste & myFile.Path & ">"
End If
Next
For Each mySubfolders In myFolder.subfolders
Liste = Liste & ""
ListOrdner mySubfolders, sFilter
Next
FehlerZugriff:
Err.Clear
Set myFile = Nothing: Set mySubfolders = Nothing: Set myFolder = Nothing
End Sub
Sub Start()
Dim sArea() As String, sArea2() As String
Dim sFileFilter As String, OName As String, sDateiName As String
Dim sFormel As String
Dim A As Long, B As Long, LCol As Long
Dim iCalc As Integer
Const InfoText As String = "Bitte warten!"
Set FS = CreateObject("Scripting.FileSystemObject")
LCol = 2 'erste Einfügezeile
sFileFilter = "*.xls" 'Filtefilter
'es werden nur die Unterordner durchsucht und gelistet
varFolder = "Z:\Abrechnung" 'welcher Ordner?
With Application
iCalc = .Calculation
.StatusBar = InfoText
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
ListOrdner varFolder, sFileFilter
sArea = Split(Liste, "")
If UBound(sArea2) > 1 Then
For B = LBound(sArea2) To UBound(sArea2)
If B = 0 Then
'Ordnername
OName = Right$(sArea2(B), Len(sArea2(B)) - InStrRev(sArea2(B), "\"))
'hier Tabellennamen eventuell anpassen!**********************
'Übersichtsdatei
With ThisWorkbook.Sheets(OName) '?
.Range("A1") = "Ordner": .Range("B1") = "Kunde": .Range("C1") = "Rabatt"
.Range("A1:Z1").Font.Bold = True
End With
Else ' B = 0
If sArea2(B) "" Then
ThisWorkbook.Sheets(OName).Cells(LCol, 1) = OName 'schreibe Ordnername
Dim strMonat As String
strMonat = InputBox("Monat eingeben:", "Monat", Format(Date, "MMMM"))
sFormel = "'" & Replace(sArea2(B), sFormel, "[" & sFormel & "]" & _
strMonat & "'!") & Range("A2").Address(, , xlR1C1)
ThisWorkbook.Sheets(OName).Cells(LCol, 2) = ExecuteExcel4Macro(sFormel) _
b>
sFormel = Replace(sFormel, Range("A2").Address(, , xlR1C1), Range("B62"). _
Address(, , xlR1C1))
ThisWorkbook.Sheets(OName).Cells(LCol, 3) = ExecuteExcel4Macro(sFormel)
LCol = LCol + 1
End If ' sArea2(B) ""
End If ' B = 0
Next B
LCol = 2
End If 'UBound(sArea2) > 1
Next A
.Calculation = iCalc
.EnableEvents = True
.ScreenUpdating = True
.StatusBar = False
End With 'Application
Erase sArea: Erase sArea2
Set FS = Nothing: Set varFolder = Nothing
Call Ergänzung_Summenfunktion
Call Ergänzung_format
End Sub