Moin,
versuch mal folgendes:
Option Explicit
Dim vRet As Variant
Dim mFso As Object
'Const Fehlermeldungen
Const m_FEHLERLAENGE As String = "Fehler: Es wird eine Gesamtlänge von 14 Zeichen erwartet."
Const m_CHR45_FEHLT As String = "Fehler: Es wird ein ""-"" an Position 6 erwartet."
Const m_CHR77_FEHLT As String = "Fehler: Es wird ein ""M"" an Position 11 erwartet."
Const m_CH32_FEHLT As String = "Fehler: Es wird ein LEERZEICHEN an Position 10 erwartet."
Const m_ISNUMERIC As String = "Fehler: Es werden Zahlen an Positionen wie in diesem Beispiel erwarten." & vbNewLine & vbNewLine & "12102-027 M118"
Const m_sPfad As String = "G:\DATEN\Herstellberichte\" '<----anpassen
Const m_FileExtension As String = ".XLSM" '<---- Dateityp anpassen und in Großbuchstaben angeben
Dim lCalc As Long
Dim lEvent As Long
Dim lStatusbar As Long
Dim lScreen As Long
Sub main()
On Error GoTo FinishErr
'*** Inputbox den gesuchten Dateinamen zu erhalten
vRet = InputBox("Nach welchem File soll gesucht werden?", "Dateinamenabfrage")
'*** ***
vRet = checkEingabe(vRet)
'*** ***
If Len(vRet) <> 14 Then
MsgBox vRet & vbNewLine & vbNewLine & "Aktion wird abgebrochen.", vbCritical + vbInformation + vbOKOnly, "Autor informiert:"
Exit Sub
End If
'*** speed up
Call TurnOffFunctionality
'*** Ordner durchsuchen
Set mFso = CreateObject("Scripting.FileSystemObject")
Call OrdnerDurchsuchen(mFso.GetFolder(m_sPfad))
FinishErr:
If Err.Number <> 0 Then
MsgBox Err.Number & vbCrLf & Err.Description
End If
'*** Standard speed
Call TurnOnFunctionality
Set mFso = Nothing
End Sub
Sub OrdnerDurchsuchen(ByRef oFolder As Object)
Dim oSubFldr As Object
Dim oFile As Object
'*** Unterordner durchsuchen
For Each oSubFldr In oFolder.SubFolders
Call OrdnerDurchsuchen(oSubFldr)
Next
'*** Dateien in den Unterordner
For Each oFile In oFolder.Files
'*** Wenn Dateintyp stimmt
If UCase(Right(oFile.Name, 5)) = m_FileExtension Then
'*** Wenn Inhalt der Inputbox mit Datei übereinstimmt
If UCase(oFile.Name) = UCase(vRet & m_FileExtension) Then
'*** dann öffne das File
Dim wkb As Excel.Workbook
Set wkb = Application.Workbooks.Add(oFile.Path)
End If
End If
Next
'*** Objektreferenzen entlassen
Set oSubFldr = Nothing
Set oFile = Nothing
Set wkb = Nothing
End Sub
Public Sub TurnOffFunctionality()
With Application
lCalc = .Calculation: .Calculation = xlCalculationManual
lStatusbar = .DisplayStatusBar: .DisplayStatusBar = False
lEvent = .EnableEvents: .EnableEvents = False
lScreen = .ScreenUpdating: .ScreenUpdating = False
End With
End Sub
Public Sub TurnOnFunctionality()
With Application
.Calculation = lCalc
.DisplayStatusBar = lStatusbar
.EnableEvents = lEvent
.ScreenUpdating = lScreen
End With
End Sub
Function checkEingabe(ByRef vRet As Variant) As Variant
Dim s As String
s = vRet
'(Länge = 14)
If Not Len(s) = 14 Then
s = m_FEHLERLAENGE
'(- vorhanden an Position 6)
ElseIf Not Mid(s, 6, 1) = Chr(45) Then
s = m_CHR45_FEHLT
'(Leerzeichen an Position 10 vorhanden)
ElseIf Not Mid(s, 10, 1) = Chr(32) Then
s = m_CH32_FEHLT
'("M" an Position 11 vorhanden)
ElseIf Not Mid(s, 11, 1) = Chr(77) Then
s = m_CHR77_FEHLT
'(Zahlen links/rechts "-") & (Zahlen rechts "M")
ElseIf Not IsNumeric((Split(Split(s, Chr(32))(0), Chr(45))(0))) _
And Not IsNumeric((Split(Split(s, Chr(32))(0), Chr(45))(1))) _
And Not IsNumeric((Split(Split(s, Chr(32))(1), Chr(77))(1))) Then
s = m_ISNUMERIC
End If
'retVal
checkEingabe = s
End Function
|