Wo ist der Wurm
25.04.2012 10:33:54
Abu
Hallo Cathy,
Sollte alles passen. Habe jetzt mal nur den Code fuer inputbox, oeffnen und filtern genommen und siehe da, es klappt.
Also steckt der Wurm wohl irgendwo anders, hier mal der komplette Code:
Sub SSuchen()
Dim sPfad$, sDatei$, sTab$, sRange$, vSuchwert$, sPath$, sPath1$, Pfad1$
Dim vErgebnis, oApp As Excel.Application, rngFund As Range
Dim monat As Integer
Dim ExcelApp As Excel.Application
Dim wbNew As Excel.Workbook
monat = Month(Date)
sPath = "G:\Sites\Beringe2\xxx\xxx\Control Tower\Express file\" & Year(Date) & "\"
sPath1 = "G:\Sites\Beringe2\xxx\xxx\Control Tower\Express file\" & Year(Date) - 1 & "\"
sPfad = sPath
sTab = "Sheet1"
sRange = "$C:$C"
vSuchwert = InputBox("Please type your S-number!")
Do
Set oApp = New Excel.Application
sDatei = Year(Date) & " Month " & monat & ".xls" 'Datei
If Dir(sPfad & sDatei) = "" Then
sDatei = Year(Date) & " Month " & monat - 1 & ".xls"
End If
With oApp.Workbooks.Open(sPfad & sDatei, ReadOnly:=True)
With .Sheets(sTab)
vErgebnis = True
Set rngFund = .Range(sRange).Columns(1).Find(what:=vSuchwert, LookIn:=xlValues, _
_
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not rngFund Is Nothing Then
vErgebnis = vSuchwert
End If
End With
.Close False
End With
oApp.Quit
Set oApp = Nothing
monat = monat - 1
Loop Until TypeName(vErgebnis) "Boolean" Or monat = 0
If TypeName(vErgebnis) = "Boolean" Then
monat = 12
Do
Set oApp = New Excel.Application
sPfad = sPath1
sDatei = Year(Date) - 1 & " Month " & monat & ".xls"
If Dir(sPfad & sDatei) = "" Then
sDatei = Year(Date) - 1 & " Month " & monat - 1 & ".xls"
End If
With oApp.Workbooks.Open(sPfad & sDatei, ReadOnly:=True)
With .Sheets(sTab)
vErgebnis = True
Set rngFund = .Range(sRange).Columns(1).Find(what:=vSuchwert, LookIn:= _
xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not rngFund Is Nothing Then
vErgebnis = vSuchwert
End If
End With
.Close False
End With
oApp.Quit
Set oApp = Nothing
monat = monat - 1
Loop Until TypeName(vErgebnis) "Boolean" Or monat = 0
End If
monat = monat + 1
If vErgebnis = True Then
MsgBox "Suchwert: " & sSuchwert & " wurde nicht gefunden!", vbExclamation
Else
Pfad1 = "G:\Sites\Beringe2\xxx\xxx\Control Tower\Express file\2011\2011 Month " & monat _
& ".xls"
Workbooks.Open Filename:=Pfad1
With Worksheets("Sheet1")
.AutoFilterMode = False
.Range("A1:T1").AutoFilter
.Range("A1:T1").AutoFilter Field:=3, Criteria1:=vErgebnis
loLetzte = IIf(IsEmpty(Cells(Rows.Count, 3)), Cells(Rows.Count, 3).End(xlUp).Row, _
Rows.Count)
Set rng = Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible)
Workbooks.Add
rng.Copy Range("A1")
Rows(1).Delete
Workbooks("2011 Month " & monat & ".xls").Close SaveChanges:=False
End With
End If
End Sub