Fehlerhaftes Script
03.02.2006 14:30:08
sheila-ann
ich nutze folgendes Script was allerdings irgendwo einen kleinen Fehler hat. Das Script soll folgendes tun:
"Liste1.xls" mit "Liste2.xls" vergleichen und übereinstimmungen in ein neues Blatt exportieren (und rot markieren)
Das Problem ist aber jetzt: Sobald in "Liste1.xls" mehr als 1 Tabellenblatt vorhanden ist, erscheint folgender Fehler:
"Laufzeitfehler '91'. "Objektvariable oder With-Blockvariable nicht festgelegt.
Sieht jemand den Fehler?
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Declare
Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare
Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public sPath As String
Public SuchArt
Public Begriff As String
Dim xZeile As Long
Dim i As Long
Dim sFile As String
Dim wbk
Dim wbkx
Dim wbky
Dim wbk1
Dim aRow As Long
Sub DateienOeffnen()
Dim arr As Variant
Dim iCounter As Integer
Dim bln As Boolean
Application.ScreenUpdating = False
bln = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Set wbkx = Workbooks("Suchmaske.xla").Worksheets("Suchergebnisse")
sFile = wbkx.Range("A1").Value
On Error GoTo Datei_oeffnen
Windows(sFile).Activate
On Error GoTo 0
Datei_oeffnen:
Workbooks.Open sFile, UpdateLinks:=False
Sheets(1).Activate
Set wbky = ActiveWorkbook.ActiveSheet
aRow = [A65536].End(xlUp).Row
For i = 1 To aRow
wbkx.Cells(i, 2) = wbky.Cells(i, 1)
Next
ActiveWorkbook.Close False
Workbooks.Add
Set wbk1 = ActiveWorkbook.ActiveSheet
i = 1
arr = FileArray(sPath, "*.xls")
For iCounter = 1 To UBound(arr)
sFile = arr(iCounter)
If WkbExists(sFile) Then
Workbooks(sFile).Activate
xOffen = True
Else
Application.StatusBar = "Durchsuche Datei " & _
arr(iCounter) & "..."
Workbooks.Open sPath & sFile, UpdateLinks:=False
End If
Suche
If xOffen = False Then Workbooks(sFile).Close False
xOffen = False
Next iCounter
Application.StatusBar = False
Application.DisplayStatusBar = bln
Application.ScreenUpdating = True
End Sub
Function FileArray(sPath As String, sPattern As String)
Dim arrFiles()
Dim iCounter As Integer
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
sFile = Dir(sPath & sPattern)
Do While sFile <> ""
iCounter = iCounter + 1
ReDim Preserve arrFiles(1 To iCounter)
arrFiles(iCounter) = sFile
sFile = Dir()
Loop
FileArray = arrFiles
End Function
Function WkbExists(sFile As String) As Boolean
Dim wkb As Object
On Error Resume Next
Set wkb = Workbooks(sFile)
If Err = 0 And Not wkb Is Nothing Then
WkbExists = True
End If
On Error GoTo 0
End Function
Function GetDirectory(Optional Msg As String) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, x As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(Msg) Then
bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
Else
bInfo.lpszTitle = Msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
Path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal Path)
If r Then
pos = InStr(Path, Chr$(0))
GetDirectory = Left(Path, pos - 1)
Else
GetDirectory = ""
End If
End Function
Sub Suche()
Dim wks As Worksheet
Dim rng As Range
Dim sZeile As Variant, sFind As String
Dim sSpalte
For Each wks In Worksheets
For k = 1 To aRow
Begriff = wbkx.Range("B" & k).Value
Set rng = wks.Cells.Find(Begriff, , , SuchArt)
If Not rng Is Nothing Then
sAddress = rng.Address
Do
sSpalte = rng.Column
Rows(rng.Row).Copy wbk1.Rows(i)
wbk1.Cells(i, sSpalte).Interior.ColorIndex = 3
i = i + 1
Set rng = Cells.FindNext(after:=rng.Offset(1, 0))
If rng.Address = sAddress Then Exit Do
Loop
End If
Next k
Next wks
End Sub
Sub Starten()
UserForm1.Show
End Sub