Warum kann ich nur 22 Datein bearbeiten?
12.06.2006 14:03:41
swen
ich habe mir folgenden Code zusammen gebastelt,
'*** Abfrage um welche Daten es sich handelt
strpath = GetOrdner() 'Die Vorauswahl kannst du auch weglassen
strtemp = strpath & "\"
'**********************************************************************************
'****** Daten in zwei Ordner (Vor und Nach tipsen) sortieren / Vorsortieren *******
'**********************************************************************************
If Dir(strtemp & "Vor Tipsen", vbDirectory) = "" Then MkDir strtemp & "Vor Tipsen"
If Dir(strtemp & "Nach Tipsen", vbDirectory) = "" Then MkDir strtemp & "Nach Tipsen"
If Dir(strtemp & "Ohne Angabe Tipsen", vbDirectory) = "" Then MkDir strtemp & "Ohne Angabe Tipsen"
Dim strtext As String
Dim i As Long
Dim intZeile As Integer
Dim strAktivSheet As String
Dim strWorkbook As String
Dim strThisWorkbook As String
Set fs = Application.FileSearch
With fs
.LookIn = strtemp 'zum Ordner
.Filename = "*.wk1" 'wenn nur Exceldateien
If .Execute > 0 Then
For z = 1 To .FoundFiles.Count ' alle Dateien im Ordner von oben nach unten aufrufen
NameF = .FoundFiles(z) 'aktuelle Datei
Workbooks.Open NameF
strThisWorkbook = ThisWorkbook.Name
strAktivSheet = ActiveSheet.Name
strWorkbook = ActiveWorkbook.Name
blnVor = False
blnNach = False
blntips = False
If Not Range("A30:M50").Find(What:="Vor") Is Nothing Then blnVor = True
If Not Range("A30:M50").Find(What:="vor") Is Nothing Then blnVor = True
If Not Range("A30:M50").Find(What:="Nach") Is Nothing Then blnNach = True
If Not Range("A30:M50").Find(What:="nach") Is Nothing Then blnNach = True
If Not Range("A30:M50").Find(What:="Tips") Is Nothing Then blntips = True
If Not Range("A30:M50").Find(What:="tips") Is Nothing Then blntips = True
If Not Range("A30:M50").Find(What:="Tipsen") Is Nothing Then blntips = True
If Not Range("A30:M50").Find(What:="tipsen") Is Nothing Then blntips = True
strtemp2 = ActiveSheet.Name & " - AutoSor.wk1"
If blnVor = True And blntips = True Then
Workbooks(strAktivSheet).SaveAs (strtemp & "Vor Tipsen\" & strtemp2)
ElseIf blnNach = True And blntips = True Then
Workbooks(strAktivSheet).SaveAs (strtemp & "Nach Tipsen\" & strtemp2)
ElseIf blnNach = False And blnVor = False Then
Workbooks(strAktivSheet).SaveAs (strtemp & "Ohne Angabe Tipsen\" & strtemp2)
End If
Application.DisplayAlerts = False
Workbooks(strtemp2).Close
Next z
End If
End With
End Sub
'Ordnerauswahl
Function GetOrdner(Optional ByVal def = "")
Dim objShell As Object, objfolder As Object
Set objShell = CreateObject("Shell.Application")
Set objfolder = objShell.BrowseForFolder(0, "Bitte einen Ordner wählen", 0, def)
If objfolder Is Nothing Then Exit Function
GetOrdner = objfolder.Self.Path
End Function
Das Problem ist das ich nicht mehr als 22 Datein verschieben kann immer wann er die 22 Datei aufmacht und sie dann verschieben möchte sagt er das es nicht weiter geht!
Warum?
Gruß
swen