müsste so gehen.
28.01.2010 15:08:37
Tino
Hallo,
'Hilfsfunktion *****************************
Sub FindWerte(ByVal Bereich As Range, ByVal SuchWert, ByRef meAR(), ByRef LCount&)
Dim strStart$, rngRange As Range
'Suchen gesamten inhalt auf Groß- u. Klein- schreibung achten
Set rngRange = Bereich.Find(What:=SuchWert, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)
If Not rngRange Is Nothing Then
Do While rngRange.Address <> strStart
LCount = LCount + 1
Redim Preserve meAR(1 To 2, LCount)
meAR(1, LCount) = rngRange.Value
meAR(2, LCount) = rngRange.Offset(0, 1).Value
If strStart = "" Then strStart = rngRange.Address
Set rngRange = Bereich.FindNext(rngRange)
Loop
End If
End Sub
Sub Beispiel_Test()
Dim oWB As Workbook
Dim oSH As Worksheet
Dim meAR(), iCount As Long
Dim rngTemp As Range
Dim NotIsOben As Boolean
Dim strSuchWert As String
Dim LCount As Long
strSuchWert = "07-70-NA*" 'auf den Platzhalter Stern achten
On Error Resume Next
'Datei an oWB
Set oWB = Workbooks("Teilnehmer.xls")
If oWB Is Nothing Then 'ist Datei offen?
'Datei öffnen Pfad zur Datei anpassen
Set oWB = Workbooks.Open("C:\Teilnehmer.xls", ReadOnly:=True)
NotIsOben = True
End If
On Error Resume Next
'konnte Datei an oWB übergeben werden?
If oWB Is Nothing Then
MsgBox "Datei nicht vorhanden!"
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
'Counter auf -1 stellen
LCount = -1
For Each oSH In oWB.Worksheets
'Suche auf Tabelle mit Parameterübergabe
FindWerte oSH.UsedRange, strSuchWert, meAR(), LCount
Next oSH
If NotIsOben Then
oWB.Close False
Else
ThisWorkbook.Activate
End If
If LCount > -1 Then 'Daten gefunden
'wo die Daten hin sollen **************************************************
'hier auf die Tabelle1 ab A2
With Sheets("Tabelle1")
'leer machen für neue Daten, eventuell löschen wenn nicht gewünscht
.Range("A2").Resize(.UsedRange.Rows.Count).ClearContents
'Daten aus Array einfügen
.Range("A2").Resize(Ubound(meAR, 2) + 1, Ubound(meAR)) = Application.Transpose(meAR)
End With
'**************************************************************************
End If
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Gruß Tino