Excel und VBA - neues Arbeitsblatt nach Suchvorgang

Re(4): Excel und VBA - neues Arbeitsblatt nach Suchvorgang

Penguin — Fri, 18 May 2007 12:45:34 GMT

zuerst, wenn du mir eine frage stellst, solltest du auch mir antworten - wie soll ich sonst die frage sehen?

Nach zig Edits, jetzt wird die Farbe auch vorher korrigiert.

zur Frage:
Sub x()
Dim wks As Worksheet
Dim strSearch As String, strFirst As String
Dim arrLocations()
Dim rngFound As Excel.Range
Dim intCounter

For Each wks In ActiveWorkbook.Worksheets
    If LCase(Trim(wks.Name)) = "fundorte" Then
        Application.DisplayAlerts = False
        wks.Delete
        Application.DisplayAlerts = True
        Exit For
    End If
Next wks

Do While Trim(strSearch) = ""
    strSearch = InputBox("Bitte Suchbegriff eingeben:")
Loop
strSearch = Trim(LCase(strSearch))
ReDim arrLocations(0 To 2, 0 To 0)
For Each wks In ActiveWorkbook.Worksheets
    Set rngFound = wks.Cells.Find(strSearch, LookIn:=xlValues)
    If Not rngFound Is Nothing Then
        strFirst = rngFound.Address
        Do
            intCounter = UBound(arrLocations, 2) + 1
            ReDim Preserve arrLocations(2, intCounter)
            arrLocations(0, intCounter) = wks.Name
            arrLocations(1, intCounter) = rngFound.Address
            arrLocations(2, intCounter) = rngFound.Text
            rngFound.Font.ColorIndex = 1
            rngFound.Characters(Start:=InStr(1, rngFound.Text, strSearch), Length:=Len(strSearch)).Font.ColorIndex = 5
            Set rngFound = wks.Cells.FindNext(rngFound)
        Loop While Not rngFound Is Nothing And rngFound.Address <> strFirst
    End If
Next wks

Worksheets.Add after:=Worksheets(Worksheets.Count)
Set wks = Worksheets(Worksheets.Count)
For intCounter = 1 To UBound(arrLocations, 2)
    wks.Cells(intCounter + 1, 1) = arrLocations(0, intCounter)
    wks.Cells(intCounter + 1, 2) = arrLocations(1, intCounter)
    wks.Cells(intCounter + 1, 3) = Left(arrLocations(2, intCounter), InStr(1, arrLocations(2, intCounter), strSearch) - 1) & UCase(strSearch) & Right(arrLocations(2, intCounter), 1 + Len(arrLocations(2, intCounter)) - InStr(1, arrLocations(2, intCounter), strSearch) - Len(strSearch))
    wks.Cells(intCounter + 1, 3).Characters(Start:=InStr(1, arrLocations(2, intCounter), strSearch), Length:=Len(strSearch)).Font.ColorIndex = 5
    wks.Hyperlinks.Add anchor:=Range("d" & intCounter + 1), Address:="", SubAddress:=arrLocations(0, intCounter) & "!" & arrLocations(1, intCounter), TextToDisplay:="...Goto"
Next
wks.Cells(1, 1) = "Tabelle"
wks.Cells(1, 2) = "Zelle"
wks.Cells(1, 3) = "Zellinhalt"
wks.Cells(1, 4) = "Link"
wks.Name = "Fundorte"
End Sub

Bei color index kannst die Farbe ändern, im Moment ists blau.

Re(4): Excel und VBA - neues Arbeitsblatt nach Suchvorgang

Penguin — Fri, 18 May 2007 12:45:34 GMT

zuerst, wenn du mir eine frage stellst, solltest du auch mir antworten - wie soll ich sonst die frage sehen?

zur Frage:

Sub x()
Dim wks As Worksheet
Dim strSearch As String, strFirst As String
Dim arrLocations()
Dim rngFound As Excel.Range
Dim intCounter

For Each wks In ActiveWorkbook.Worksheets
    If LCase(Trim(wks.Name)) = "fundorte" Then
        Application.DisplayAlerts = False
        wks.Delete
        Application.DisplayAlerts = True
        Exit For
    End If
Next wks

Do While Trim(strSearch) = ""
    strSearch = InputBox("Bitte Suchbegriff eingeben:")
Loop
strSearch = Trim(LCase(strSearch))
ReDim arrLocations(0 To 2, 0 To 0)
For Each wks In ActiveWorkbook.Worksheets
    Set rngFound = wks.Cells.Find(strSearch, LookIn:=xlValues)
    If Not rngFound Is Nothing Then
        strFirst = rngFound.Address
        Do
            intCounter = UBound(arrLocations, 2) + 1
            ReDim Preserve arrLocations(2, intCounter)
            arrLocations(0, intCounter) = wks.Name
            arrLocations(1, intCounter) = rngFound.Address
            arrLocations(2, intCounter) = rngFound.Text
            rngFound.Characters(Start:=InStr(1, rngFound.Text, strSearch), Length:=Len(strSearch)).Font.ColorIndex = 5
            Set rngFound = wks.Cells.FindNext(rngFound)
        Loop While Not rngFound Is Nothing And rngFound.Address <> strFirst
    End If
Next wks

Worksheets.Add after:=Worksheets(Worksheets.Count)
Set wks = Worksheets(Worksheets.Count)
For intCounter = 1 To UBound(arrLocations, 2)
    wks.Cells(intCounter + 1, 1) = arrLocations(0, intCounter)
    wks.Cells(intCounter + 1, 2) = arrLocations(1, intCounter)
    wks.Cells(intCounter + 1, 3) = arrLocations(2, intCounter)
    wks.Cells(intCounter + 1, 3).Characters(Start:=InStr(1, arrLocations(2, intCounter), strSearch), Length:=Len(strSearch)).Font.ColorIndex = 5
    wks.Hyperlinks.Add anchor:=Range("d" & intCounter + 1), Address:="", SubAddress:=arrLocations(0, intCounter) & "!" & arrLocations(1, intCounter), TextToDisplay:="...Goto"
Next
wks.Cells(1, 1) = "Tabelle"
wks.Cells(1, 2) = "Zelle"
wks.Cells(1, 3) = "Zellinhalt"
wks.Cells(1, 4) = "Link"
wks.Name = "Fundorte"
End Sub

Bei color index kannst die Farbe ändern, im Moment ists blau.

Re(4): Excel und VBA - neues Arbeitsblatt nach Suchvorgang

Penguin — Fri, 18 May 2007 12:45:34 GMT

zuerst, wenn du mir eine frage stellst, solltest du auch mir antworten - wie soll ich sonst die frage sehen?

zur Frage:

Sub x()
Dim wks As Worksheet
Dim strSearch As String, strFirst As String
Dim arrLocations()
Dim rngFound As Excel.Range
Dim intCounter

For Each wks In ActiveWorkbook.Worksheets
    If LCase(Trim(wks.Name)) = "fundorte" Then
        Application.DisplayAlerts = False
        wks.Delete
        Application.DisplayAlerts = True
        Exit For
    End If
Next wks

Do While Trim(strSearch) = ""
    strSearch = InputBox("Bitte Suchbegriff eingeben:")
Loop
strSearch = Trim(LCase(strSearch))
ReDim arrLocations(0 To 2, 0 To 0)
For Each wks In ActiveWorkbook.Worksheets
    Set rngFound = wks.Cells.Find(strSearch, LookIn:=xlValues)
    If Not rngFound Is Nothing Then
        strFirst = rngFound.Address
        Do
            intCounter = UBound(arrLocations, 2) + 1
            ReDim Preserve arrLocations(2, intCounter)
            arrLocations(0, intCounter) = wks.Name
            arrLocations(1, intCounter) = rngFound.Address
            arrLocations(2, intCounter) = rngFound.Text
            rngFound.Characters(Start:=InStr(1, rngFound.Text, strSearch), Length:=Len(strSearch)).Font.ColorIndex = 5
            Set rngFound = wks.Cells.FindNext(rngFound)
        Loop While Not rngFound Is Nothing And rngFound.Address <> strFirst
    End If
Next wks

Worksheets.Add after:=Worksheets(Worksheets.Count)
Set wks = Worksheets(Worksheets.Count)
For intCounter = 1 To UBound(arrLocations, 2)
    wks.Cells(intCounter + 1, 1) = arrLocations(0, intCounter)
    wks.Cells(intCounter + 1, 2) = arrLocations(1, intCounter)
    wks.Cells(intCounter + 1, 3) = arrLocations(2, intCounter)
    wks.Cells(intCounter + 1, 3).Characters(Start:=InStr(1, rngFound.Text, strSearch), Length:=Len(strSearch)).Font.ColorIndex = 5
    wks.Hyperlinks.Add anchor:=Range("d" & intCounter + 1), Address:="", SubAddress:=arrLocations(0, intCounter) & "!" & arrLocations(1, intCounter), TextToDisplay:="...Goto"
Next
wks.Cells(1, 1) = "Tabelle"
wks.Cells(1, 2) = "Zelle"
wks.Cells(1, 3) = "Zellinhalt"
wks.Cells(1, 4) = "Link"
wks.Name = "Fundorte"
End Sub

Bei color index kannst die Farbe ändern, im Moment ists blau.

Re(4): Excel und VBA - neues Arbeitsblatt nach Suchvorgang

Penguin — Fri, 18 May 2007 12:45:34 GMT

zuerst, wenn du mir eine frage stellst, solltest du auch mir antworten - wie soll ich sonst die frage sehen?

zur Frage:

Sub x()
Dim wks As Worksheet
Dim strSearch As String, strFirst As String
Dim arrLocations()
Dim rngFound As Excel.Range
Dim intCounter

For Each wks In ActiveWorkbook.Worksheets
    If LCase(Trim(wks.Name)) = "fundorte" Then
        Application.DisplayAlerts = False
        wks.Delete
        Application.DisplayAlerts = True
        Exit For
    End If
Next wks

Do While Trim(strSearch) = ""
    strSearch = InputBox("Bitte Suchbegriff eingeben:")
Loop
strSearch = Trim(LCase(strSearch))
ReDim arrLocations(0 To 2, 0 To 0)
For Each wks In ActiveWorkbook.Worksheets
    Set rngFound = wks.Cells.Find(strSearch, LookIn:=xlValues)
    If Not rngFound Is Nothing Then
        strFirst = rngFound.Address
        Do
            intCounter = UBound(arrLocations, 2) + 1
            ReDim Preserve arrLocations(2, intCounter)
            arrLocations(0, intCounter) = wks.Name
            arrLocations(1, intCounter) = rngFound.Address
            arrLocations(2, intCounter) = rngFound.Text
            rngFound.Characters(Start:=InStr(1, rngFound.Text, strSearch), Length:=Len(strSearch)).Font.ColorIndex = 5
            Set rngFound = wks.Cells.FindNext(rngFound)
        Loop While Not rngFound Is Nothing And rngFound.Address <> strFirst
    End If
Next wks

Worksheets.Add after:=Worksheets(Worksheets.Count)
Set wks = Worksheets(Worksheets.Count)
For intCounter = 1 To UBound(arrLocations, 2)
    wks.Cells(intCounter + 1, 1) = arrLocations(0, intCounter)
    wks.Cells(intCounter + 1, 2) = arrLocations(1, intCounter)
    wks.Cells(intCounter + 1, 3) = arrLocations(2, intCounter)
    wks.Hyperlinks.Add anchor:=Range("d" & intCounter + 1), Address:="", SubAddress:=arrLocations(0, intCounter) & "!" & arrLocations(1, intCounter), TextToDisplay:="...Goto"
Next
wks.Cells(1, 1) = "Tabelle"
wks.Cells(1, 2) = "Zelle"
wks.Cells(1, 3) = "Zellinhalt"
wks.Cells(1, 4) = "Link"
wks.Name = "Fundorte"
End Sub

Re(3): Excel und VBA - neues Arbeitsblatt nach Suchvorgang

SunnyHill — Fri, 18 May 2007 11:21:29 GMT

Nochmals ne Frage

Wie kann ich in den angezeigten Fundstellen den Suchbegriff farblich hervorheben?

Suchbegriff war zB "test" und gefunden werden "testlauf", "Testurteil", "Wochenendtestmaschine". In den gefundenen Worten soll jedoch nur "test" farblich angezeigt werden. Ich schaffe es bis jetzt nur, die gesamte Zelle hervorzuheben.

Vielen Dank!

SunnyHill.

Re(2): Excel und VBA - neues Arbeitsblatt nach Suchvorgang

SunnyHill — Tue, 15 May 2007 08:33:39 GMT

Hallo und sorry für die späte Antwort.....

Funktioniert bestens....vielen Dank!

SunnyHill.

Re: Excel und VBA - neues Arbeitsblatt nach Suchvorgang

Penguin — Sun, 13 May 2007 12:15:15 GMT

Sub x()
Dim wks As Worksheet
Dim strSearch As String, strFirst As String
Dim arrLocations()
Dim rngFound As Excel.Range
Dim intCounter

Do While Trim(strSearch) = ""
    strSearch = InputBox("Bitte Suchbegriff eingeben:")
Loop
strSearch = Trim(LCase(strSearch))
ReDim arrLocations(0 To 2, 0 To 0)
For Each wks In ActiveWorkbook.Worksheets
    Set rngFound = wks.Cells.Find(strSearch, LookIn:=xlValues)
    If Not rngFound Is Nothing Then
        strFirst = rngFound.Address
        Do
            intCounter = UBound(arrLocations, 2) + 1
            ReDim Preserve arrLocations(2, intCounter)
            arrLocations(0, intCounter) = wks.Name
            arrLocations(1, intCounter) = rngFound.Address
            arrLocations(2, intCounter) = rngFound.Text
            Set rngFound = wks.Cells.FindNext(rngFound)
        Loop While Not rngFound Is Nothing And rngFound.Address <> strFirst
    End If
Next wks
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set wks = Worksheets(Worksheets.Count)
For intCounter = 1 To UBound(arrLocations, 2)
    wks.Cells(intCounter + 1, 1) = arrLocations(0, intCounter)
    wks.Cells(intCounter + 1, 2) = arrLocations(1, intCounter)
    wks.Cells(intCounter + 1, 3) = arrLocations(2, intCounter)
    wks.Hyperlinks.Add anchor:=Range("d" & intCounter + 1), Address:="", SubAddress:=arrLocations(0, intCounter) & "!" & arrLocations(1, intCounter), TextToDisplay:="...Goto"
Next
wks.Cells(1, 1) = "Tabelle"
wks.Cells(1, 2) = "Zelle"
wks.Cells(1, 3) = "Zellinhalt"
wks.Cells(1, 4) = "Link"
wks.name="Fundorte"
End Sub

vor dem schließen löscht du dann das blatt:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Worksheets("Fundorte").Delete
End Sub

Re: Excel und VBA - neues Arbeitsblatt nach Suchvorgang

Penguin — Sun, 13 May 2007 12:15:15 GMT

Sub x()
Dim wks As Worksheet
Dim strSearch As String, strFirst As String
Dim arrLocations()
Dim rngFound As Excel.Range
Dim intCounter

Do While Trim(strSearch) = ""
    strSearch = InputBox("Bitte Suchbegriff eingeben:")
Loop
strSearch = Trim(LCase(strSearch))
ReDim arrLocations(0 To 2, 0 To 0)
For Each wks In ActiveWorkbook.Worksheets
    Set rngFound = wks.Cells.Find(strSearch, LookIn:=xlValues)
    If Not rngFound Is Nothing Then
        strFirst = rngFound.Address
        Do
            intCounter = UBound(arrLocations, 2) + 1
            ReDim Preserve arrLocations(2, intCounter)
            arrLocations(0, intCounter) = wks.Name
            arrLocations(1, intCounter) = rngFound.Address
            arrLocations(2, intCounter) = rngFound.Text
            Set rngFound = wks.Cells.FindNext(rngFound)
        Loop While Not rngFound Is Nothing And rngFound.Address <> strFirst
    End If
Next wks
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set wks = Worksheets(Worksheets.Count)
For intCounter = 1 To UBound(arrLocations, 2)
    wks.Cells(intCounter + 1, 1) = arrLocations(0, intCounter)
    wks.Cells(intCounter + 1, 2) = arrLocations(1, intCounter)
    wks.Cells(intCounter + 1, 3) = arrLocations(2, intCounter)
    wks.Hyperlinks.Add anchor:=Range("d" & intCounter + 1), Address:="", SubAddress:=arrLocations(0, intCounter) & "!" & arrLocations(1, intCounter), TextToDisplay:="...Goto"
Next
wks.Cells(1, 1) = "Tabelle"
wks.Cells(1, 2) = "Zelle"
wks.Cells(1, 3) = "Zellinhalt"
wks.Cells(1, 4) = "Link"
wks.name="Fundorte"
End Sub

bevor dem schließen löscht du dann das blatt:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Worksheets("Fundorte").Delete
End Sub

Re(3): Excel und VBA - neues Arbeitsblatt nach Suchvorgang

dreamer30 — Sun, 13 May 2007 05:14:57 GMT

GANZ hab ich die aufgabenstellung immer noch ned, ich stells mir momentan so vor: du gibst in die inputbox einen string ein, nehmen wir an er sei "Auto".

Dann kommen im aktuellen sheet Begriffe vor wie "Auto", "Automatik","Autodidakt","Modellauto" etc...

Das ergebnis soll dann so aussehen, dass Die begriffe angefuehrt sind in denen der String "Auto" vorkam und die dazugehoerige Fundstelle, und die ausgabe dieser Resultate in einer fortlaufenden Liste auf einem extra excelsheet oder sonst irgendeiner textdatei ?

Re(2): Excel und VBA - neues Arbeitsblatt nach Suchvorgang

SunnyHill — Sun, 13 May 2007 04:45:22 GMT

Genau!

Ich habe ja schon eine komplette Routine dafür geschrieben, und funktioniert auch alles bestens. Jedoch bekomme ich es nicht hin, die Suchergebnisse auf einem neuen Arbeitsblatt anzuzeigen. Bisher habe ich die Lösung, dass überhaupt eine neue Datei erstellt wird, und dort werden die Ergebnisse angezeigt und das ist eben das Problem. Ich benötigte die Ergebnisse sowie die durchsuchten Daten in einer Datei. *kompliziert*

Vielen Dank, SunnyHill.

Re: Excel und VBA - neues Arbeitsblatt nach Suchvorgang

dreamer30 — Sat, 12 May 2007 21:15:59 GMT

Wie meinst das ? d.h. du willst eine inputbox und gibst dort einen string ein, hernach soll das aktuelle arbeitsblatt nach diesem string durchsucht werden und dir auf einem 2. arbeitsblatt die Zellen ausgeben in denen dieser string gefunden wird ?

Excel und VBA - neues Arbeitsblatt nach Suchvorgang

SunnyHill — Sat, 12 May 2007 17:26:42 GMT

Hallo!

Ich schaffe es nicht, in Excel nach einer erfolgten "Input"-Abfrage, die Suchergebnisse in einem neuen Arbeitsblatt in der selben Datei zu erstellen, welches beim Schließen der Datei (ohne Abfrage) auch wieder gelöscht wird.

Also:

Input -> Dateien und Arbeitsblätter werden durchsucht -> neues Arbeitsblatt erstellen -> Fundstellen anzeigen -> Arbeitsblatt bei schließen löschen.

Geht das überhaupt?

Vielen Dank, SunnyHill.