durchsuchen eines Unterordners
16.01.2007 21:31:26
fuzzi
Mein Makro durchsucht einen Ordner (fertigzustellende Rechnungen) um dort die bislang höchste fortlaufende Zahl zu finden, und dann um eins eröht eine neue Tabelle abzuspeichern.
Kann man das so ändern, dass ein darin befindlicher Unterordner mit durchsucht wird? Dorthin muß ich die Dateien nämlich teilweise verschiebe. Danke für die Hilfe hier mein derzeitiger Code:
Sub speichern_unter()
Dim strOrdn As String, intN As Integer, strName As String, strTxt As String
Dim strFile As String
strOrdn = "D:\Eigene Dateien\Ordi\Buchhaltung\fertigzustellende Rechnungen"
If UCase(Range("c2")) = "X" Then
strOrdn = strOrdn & " L\"
ElseIf UCase(Range("c3")) = "X" Then
strOrdn = strOrdn & " VB\"
Else
MsgBox "Zuordnung Linz - VB nicht korrekt"
Exit Sub
End If
strFile = Dir(strOrdn & Cells(82, 4) & "*.xls")
If strFile > "" Then
Application.DisplayAlerts = True ' False wenn ohne Warnung überschrieben werden soll
ActiveWorkbook.SaveAs filename:=strFile ' wenn es "Name Vorname*.xls" schon gibt
Application.DisplayAlerts = True ' wenn ohne Warnung überschrieben wurde
Else
HoleNr strOrdn, strTxt, intN ' neuen Dateinamen bestimmen
If intN >= 0 Then _
ActiveWorkbook.SaveAs filename:= _
strOrdn & Cells(82, 4) & " " & strTxt & "-" & Format(intN, "000") & ".xls"
End If
End Sub
Sub HoleNr(strOrdner As String, strText As String, intMax As Integer)
Dim objFSO As Object, objFol As Object, objFile As Object
Dim intNr As Integer, strTn As String
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFol = objFSO.GetFolder(strOrdner)
For Each objFile In objFol.Files
'abcd xyz 2006-04-556.xls
If objFile.Name Like "* ####-##-###.xls" Then
strTn = Left(Right(objFile.Name, 15), 7)
Select Case strText
Case strTn
Case "": strText = strTn
Case Is <> strTn
intMax = -1
MsgBox "In '" & strOrdner & "' stehen Dateien zu verschiedenen Monaten.", _
vbCritical, "Abbruch"
Exit Sub
End Select
intNr = Left(Right(objFile.Name, 7), 3)
If intMax < intNr Then intMax = intNr
End If
Next objFile
intMax = intMax + 1
End Sub